[mcclim-cvs] CVS mcclim/Backends/gtkairo

[dlichteblau]

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo
In directory clnet:/tmp/cvs-serv21118

Modified Files:
	frame-manager.lisp gadgets.lisp 
Log Message:
Print context menu items properly.

	* frame-manager.lisp (frame-manager-menu-choose): Pass PRINTER to
	MAKE-CONTEXT-MENU.
	
	* gadgets.lisp (make-context-menu): Use new argument PRINTER, or
	PRINT-MENU-ITEM, instead of PRINC-TO-STRING.


--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp	2006/11/12 20:12:19	1.6
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp	2006/11/12 20:37:14	1.7
@@ -129,7 +129,7 @@
 	  cell-align-x cell-align-y scroll-bars pointer-documentation)
   (declare
    ;; XXX hallo?
-   (ignore printer presentation-type default-item default-item-p
+   (ignore presentation-type default-item default-item-p
 	   text-style label cache unique-id id-test cache-value
 	   cache-test max-width max-height n-rows n-columns x-spacing
 	   y-spacing row-wise cell-align-x cell-align-y scroll-bars
@@ -139,7 +139,7 @@
 		    *application-frame*))
 	 (port (port frame))
 	 (sheet (make-instance 'dummy-context-menu-sheet))
-	 (menu (make-context-menu port sheet items)))
+	 (menu (make-context-menu port sheet items :printer printer)))
     (invoke-later
      (lambda ()
        (invoke-later (lambda () (gdk_pointer_ungrab GDK_CURRENT_TIME)))
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp	2006/11/12 20:12:19	1.8
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp	2006/11/12 20:37:14	1.9
@@ -284,12 +284,15 @@
      (value :initarg :value :accessor dummy-menu-item-sheet-value)
      (itemspec :initarg :itemspec :accessor dummy-menu-item-sheet-itemspec)))
 
-(defun make-context-menu (port sheet items)
+(defun make-context-menu (port sheet items &key printer)
   (let ((menu (gtk_menu_new)))
     (dolist (itemspec items)
       (multiple-value-bind (type display-object value sub-items)
 	  (destructure-mc-menu-item itemspec)
-	(let* ((label (princ-to-string display-object))
+	(let* ((label (with-output-to-string (s)
+			(funcall (or printer #'print-menu-item)
+				 display-object
+				 s)))
 	       (gtkmenuitem
 		(ecase type
 		  (:divider