..

original commit: 84ea0db106491b81da90eff3655eecfe110969a2

collects/framework/frame.ss

@@ -36,7 +36,8 @@
 		     make-root-area-container
 		     close))
   (define basic-mixin
-    (mixin (frame<%>) (basic<%>) args
+    (mixin (frame<%>) (basic<%>)
+	   (label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null])
       (rename [super-can-close? can-close?]
 	      [super-on-close on-close]
 	      [super-on-focus on-focus])
@@ -71,12 +72,18 @@
 	   (when (can-close?)
 	     (on-close)
 	     (show #f)))])
-      (sequence
-	(apply super-init args)
       
-	;; must make menu before inserting frame into group
-	;; or initial windows menu will be wrong
-	(make-object menu% "Windows" (make-object (get-menu-bar%) this))
+      (sequence
+	(let ([mdi-parent (send (group:get-the-frame-group) get-mdi-parent)])
+	  (super-init label
+		      (or parent mdi-parent)
+		      width height x y
+		      (cond
+		       [parent style]
+		       [mdi-parent (cons 'mdi-child style)]
+		       [else style])))
+
+	(make-object (get-menu-bar%) this)
 	(send (group:get-the-frame-group) insert-frame this))
       (private
 	[panel (make-root-area-container (get-area-container%) this)])

collects/framework/group.ss

@@ -1,11 +1,14 @@
 (unit/sig framework:group^
   (import mred-interfaces^
+	  [application : framework:application^]
 	  [frame : framework:frame^]
 	  [mzlib:function : mzlib:function^]
 	  [mzlib:file : mzlib:file^])
 
   (define-struct frame (frame id))
   
+  (define mdi-parent #f)
+
   (define %
     (class object% ()
       (private
@@ -93,6 +96,21 @@
 			     (set-close-menu-item-state! a-frame #t))
 			   frames))))])
       (public
+
+	[get-mdi-parent
+	 (lambda ()
+	   (if (eq? (system-type) 'windows)
+	       (begin
+		 (set! get-mdi-parent (lambda () mdi-parent))
+		 (set! mdi-parent (make-object frame% (application:current-app-name)
+					       #f #f #f #f #f
+					       '(mdi-parent)))
+		 (send mdi-parent show #t)
+		 mdi-parent)
+	       (begin
+		 (set! get-mdi-parent (lambda () #f))
+		 #f)))]
+
 	[set-empty-callbacks
 	 (lambda (test close-down) 
 	   (set! empty-test test)