Default gesture command translator doesn't use the matching present method for documentation

[gsou]

When I right click on a presentation where the object is a plist, the commands with a :select gesture using the default :documentation method show the whole object (using the presentation type (sequence t) for a plist) instead of calling the present method for the specified presentation type (in this case example).

For instance, here I have a presentation type example where the object is a plist, and a CLOS object:

(ql:quickload :mcclim)
(in-package :clim-user)

(define-presentation-type example ())
(defparameter *large-list* `(:name "Large List" :additionnal-metadata ,(loop for i from 1 to 512 collect i) ))
(defclass example-clos () ((name :initarg :name)))

(define-presentation-method present
    (object (type example) stream (view textual-view) &key acceptably for-context-type)
  (declare (ignore acceptably for-context-type))
  (format stream "!!~A!!" (getf object :name)))
(define-presentation-method present
    (object (type example-clos) stream (view textual-view) &key acceptably for-context-type)
  (declare (ignore acceptably for-context-type))
  (format stream "!!~A!!" (slot-value object 'name)))

(define-application-frame example () ()
  (:panes (p :application :display-function (lambda (frame stream) (declare (ignore frame))
                                              (present *large-list* 'example :stream stream)
                                              (present (make-instance 'example-clos :name "CLOS Object") 'example-clos :stream stream))))
  (:layouts (default p)))
(define-example-command (com-test-gesture :name t) ((eg 'example :gesture :select)))
(define-example-command (com-test-gesture-clos :name t) ((eg 'example-clos :gesture :select)))
(defun run () (run-frame-top-level (make-application-frame 'example)))

When right clicking, the clos object shows correctly in the menu, but not the list, which is shown in its entirety:

I was expecting the make-default-documentation function in make-command-translators to do something like the following to use the presentation type specified in the command:

(in-package :clim-internals)
(defun make-command-translators (command-name command-table args)
  (let ((readable-command-name
          ;; XXX or :NAME
          (command-name-from-symbol command-name)))
    (labels ((make-default-documentation (presentation-type)
               `((object stream)
                 (orf stream *standard-output*)
                 (format stream "~A " ,readable-command-name)
                 (present object ,(if presentation-type
                                      (list 'quote presentation-type)
                                      '(presentation-type-of object))
                          :stream stream
                          :acceptably nil
                          :sensitive nil)))
             (make-define-gesture-translator (gesture-arg name ptype gesture)
               (let ((command-args
                       (loop for arg in args
                             for (nil nil . options) = arg
                             collect (if (eq arg gesture-arg)
                                         'object
                                         (getf options :default
                                               '*unsupplied-argument-marker*)))))
                 (multiple-value-bind (gesture translator-options)
                     (if (listp gesture)
                         (values (car gesture) (cdr gesture))
                         (values gesture nil))
                   (let ((eptype (eval ptype)))
                     `(define-presentation-to-command-translator
                          ,(make-command-function-name
                            command-name ':translate name)
                          (,eptype ,command-name ,command-table
                           :gesture ,gesture
                           ,@(unless (getf translator-options :documentation)
                               `(:documentation ,(make-default-documentation eptype)))
                           ,@translator-options)
                          (object)
                        (list ,@command-args)))))))
      (loop for arg in args
            for (name ptype . options) = arg
            for gesture = (getf options :gesture)
            when gesture
            collect (make-define-gesture-translator arg name ptype gesture)))))

In this case, the menus are shown with the specified presentation type, which is what I want:

Is this intended behavior ?