..

original commit: a2ee8faf8fea8e98e8d93f36209358f19f23fff0

collects/framework/private/frame.ss

@@ -221,8 +221,12 @@
           (super-instantiate ())
           (accept-drop-files #t)
             
-          (make-object menu:can-restore-underscore-menu% (string-constant windows-menu-label)
-            (make-object (get-menu-bar%) this))
+          (let ([mb (make-object (get-menu-bar%) this)])
+            (when (or (eq? (system-type) 'macos)
+                      (eq? (system-type) 'macosx))
+              (make-object menu:can-restore-underscore-menu% (string-constant windows-menu-label)
+                mb)))
+          
           (reorder-menus this)
           (send (group:get-the-frame-group) insert-frame this)
           [define panel (make-root-area-container (get-area-container%) this)]

collects/framework/private/group.ss

@@ -36,6 +36,7 @@
 
           [define windows-menus null]
           
+          ;; get-windows-menu : (is-a?/c frame%) -> (union false? (is-a?/c menu%))
           [define get-windows-menu
             (lambda (frame)
               (let ([menu-bar (send frame get-menu-bar)])
@@ -54,16 +55,17 @@
                   (set! windows-menus (cons menu windows-menus)))))]
           [define remove-windows-menu
             (lambda (frame)
-              (let* ([menu (get-windows-menu frame)])
+              (let ([menu (get-windows-menu frame)])
                 
-                ;; to help the (conservative) gc.
-                (for-each (lambda (i) (send i delete)) (send menu get-items))
+                (when menu
+                  ;; to help the (conservative) gc.
+                  (for-each (lambda (i) (send i delete)) (send menu get-items))
                 
-                (set! windows-menus
-                      (remove
-                       menu
-                       windows-menus
-                       eq?))))]
+                  (set! windows-menus
+                        (remove
+                         menu
+                         windows-menus
+                         eq?)))))]
           
           [define (update-windows-menus)
             (let* ([windows (length windows-menus)]

collects/framework/splash.ss

@@ -2,10 +2,13 @@
 (module splash mzscheme
   (require (lib "class.ss")
            (lib "file.ss")
-           (lib "mred.ss" "mred"))
+           (lib "mred.ss" "mred")
+           (lib "contracts.ss"))
   
-  (provide get-splash-bitmap get-splash-canvas get-splash-eventspace get-dropped-files 
-           start-splash shutdown-splash close-splash)
+  (provide get-splash-bitmap set-splash-bitmap
+           get-splash-canvas get-splash-eventspace get-dropped-files 
+           start-splash shutdown-splash close-splash add-splash-icon set-splash-char-observer)
+
   
   (define splash-filename #f)
   (define splash-bitmap #f)
@@ -13,9 +16,22 @@
   (define dropped-files null)
   
   (define (get-splash-bitmap) splash-bitmap)
+  (define (set-splash-bitmap bm) 
+    (set! splash-bitmap bm)
+    (send splash-canvas on-paint))
   (define (get-splash-canvas) splash-canvas)
   (define (get-splash-eventspace) splash-eventspace)
   (define (get-dropped-files) dropped-files)
+
+  (define char-observer void)
+  (define (set-splash-char-observer proc)
+    (set! char-observer proc))
+  
+  (define-struct icon (bm x y))
+  (define icons null)
+  (define (add-splash-icon bm x y)
+    (set! icons (cons (make-icon bm x y) icons))
+    (send splash-canvas on-paint))
   
   (define (start-splash _splash-filename _splash-title width-default)
     (set! splash-title _splash-title)
@@ -170,10 +186,18 @@
   (define splash-canvas%
     (class canvas%
       (inherit get-dc)
+      (define/override (on-char evt) (char-observer evt))
       (define/override (on-paint)
-        (if splash-bitmap
-            (send (get-dc) draw-bitmap splash-bitmap 0 0)
-            (send (get-dc) clear)))
+        (let ([dc (get-dc)])
+          (if splash-bitmap
+              (send dc draw-bitmap splash-bitmap 0 0)
+              (send dc clear))
+          (for-each (lambda (icon)
+                      (send dc draw-bitmap
+                            (icon-bm icon)
+                            (icon-x icon)
+                            (icon-y icon)))
+                    icons)))
       (super-instantiate ())))
   
   (define splash-frame