From bf031be73e97771b8d45fbb257d912f0e54f32ec Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 7 Jan 2011 09:23:51 -0600
Subject: [PATCH] what happened here?

---
 collects/tests/framework/canvas.rkt           |   9 +-
 collects/tests/framework/debug.rkt            |   3 +-
 collects/tests/framework/exit.rkt             |   5 +-
 collects/tests/framework/frame.rkt            |  33 ++-
 collects/tests/framework/group-test.rkt       |  38 +--
 collects/tests/framework/keys.rkt             |  35 +--
 collects/tests/framework/load.rkt             |   6 +-
 collects/tests/framework/mem.rkt              |  10 +-
 collects/tests/framework/panel-single.rkt     | 259 +++++++++---------
 collects/tests/framework/pasteboard.rkt       |  15 +-
 collects/tests/framework/prefs.rkt            |  32 +--
 collects/tests/framework/scheme.rkt           |   4 +-
 collects/tests/framework/search.rkt           |   6 +-
 collects/tests/framework/test-suite-utils.rkt |  31 ++-
 collects/tests/framework/text.rkt             |  46 ++--
 15 files changed, 255 insertions(+), 277 deletions(-)

diff --git a/collects/tests/framework/canvas.rkt b/collects/tests/framework/canvas.rkt
index 767a292a4f..3e4018b14f 100644
--- a/collects/tests/framework/canvas.rkt
+++ b/collects/tests/framework/canvas.rkt
@@ -1,18 +1,18 @@
-(module canvas mzscheme
-  (require "test-suite-utils.ss")
+#lang racket/base
+(require "test-suite-utils.ss")
 
 (define (test-creation class name)
   (test
    name
    (lambda (x) (eq? 'passed x))
    (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       `(let* ([f (make-object frame:basic% "test canvas" #f 300 300)]
 	      [c (make-object ,class (send f get-area-container))])
 	 (send c set-editor (make-object text:wide-snip%))
 	 (send f show #t)))
       (wait-for-frame "test canvas")
-      (send-sexp-to-mred
+      (queue-sexp-to-mred
        `(send (get-top-level-focus-window) show #f))
       'passed)))
 
@@ -25,4 +25,3 @@
 	       'canvas:wide-snip-mixin-creation)
 (test-creation 'canvas:wide-snip%
 	       'canvas:wide-snip%-creation)
-)
diff --git a/collects/tests/framework/debug.rkt b/collects/tests/framework/debug.rkt
index 32ef56760b..9335214488 100644
--- a/collects/tests/framework/debug.rkt
+++ b/collects/tests/framework/debug.rkt
@@ -1,4 +1,5 @@
-#lang mzscheme
+#lang racket/base
+(require (for-syntax racket/base))
 (provide debug-printf debug-when)
 
 ;; all of the steps in the tcp connection
diff --git a/collects/tests/framework/exit.rkt b/collects/tests/framework/exit.rkt
index 00e597136f..0e93df9b99 100644
--- a/collects/tests/framework/exit.rkt
+++ b/collects/tests/framework/exit.rkt
@@ -1,5 +1,5 @@
-(module exit mzscheme
-  (require "test-suite-utils.ss")
+#lang racket/base
+(require "test-suite-utils.ss")
 
 (test 'exit/no-prompt
       (lambda (x)
@@ -47,4 +47,3 @@
 	 (with-handlers ([eof-result? (lambda (x) 'passed)])
 	   (send-sexp-to-mred
 	    `(exit:exit))))))
-)
diff --git a/collects/tests/framework/frame.rkt b/collects/tests/framework/frame.rkt
index a6a8725394..15ed81b15a 100644
--- a/collects/tests/framework/frame.rkt
+++ b/collects/tests/framework/frame.rkt
@@ -1,4 +1,5 @@
-(module frame mzscheme
+#lang racket/base
+
   (require "test-suite-utils.ss")
   
   (send-sexp-to-mred '(send (make-object frame:basic%
@@ -11,12 +12,10 @@
      (lambda (x) (eq? 'passed x))
      (lambda ()
        (let ([frame-label
-              (send-sexp-to-mred
-               `(queue-callback/res
-                 (λ ()
-                   (let ([f (instantiate ,class-expression () ,@args)])
-                     (send f show #t)
-                     (send f get-label)))))])
+              (queue-sexp-to-mred
+               `(let ([f (instantiate ,class-expression () ,@args)])
+                  (send f show #t)
+                  (send f get-label)))])
          (wait-for-frame frame-label)
          (queue-sexp-to-mred
           '(send (get-top-level-focus-window) close))
@@ -110,7 +109,7 @@
          (equal? x test-file-contents))
        (lambda ()
          (let ([frame-name 
-                (send-sexp-to-mred
+                (queue-sexp-to-mred
                  `(let ([frame (new ,class-expression)])
                     (preferences:set 'framework:file-dialogs 'common)
                     (send frame show #t)
@@ -122,10 +121,11 @@
            (call-with-output-file tmp-file
              (lambda (port)
                (display test-file-contents port))
-             'truncate)
+             #:exists 'truncate)
+           (queue-sexp-to-mred
+            `(send (find-labelled-window "Filename:") focus))
            (send-sexp-to-mred
-            `(begin (send (find-labelled-window "Filename:") focus)
-                    ,(case (system-type)
+            `(begin ,(case (system-type)
                        [(macos macosx) `(test:keystroke #\a '(meta))]
                        [(unix) `(test:keystroke #\a '(meta))]
                        [(windows) `(test:keystroke #\a '(control))]
@@ -135,16 +135,15 @@
                     (test:keystroke #\return)))
            (wait-for-frame tmp-file-name)
            (begin0
+             (queue-sexp-to-mred
+              `(let* ([w (get-top-level-focus-window)])
+                 (send (send w get-editor) get-text)))
              (send-sexp-to-mred
-              `(let* ([w (get-top-level-focus-window)]
-                      [t (send (send w get-editor) get-text)])
-                 (test:close-top-level-window w)
-                 t))
+              `(test:close-top-level-window (get-top-level-focus-window)))
              (wait-for-frame frame-name)
              (queue-sexp-to-mred
               `(send (get-top-level-focus-window) close))))))))
   
   (test-open "frame:searchable open" 'frame:searchable%)
   (test-open "frame:text open" 'frame:text%)
-  
-  )
+
diff --git a/collects/tests/framework/group-test.rkt b/collects/tests/framework/group-test.rkt
index 65a8d39348..60dd18aa6e 100644
--- a/collects/tests/framework/group-test.rkt
+++ b/collects/tests/framework/group-test.rkt
@@ -1,4 +1,4 @@
-#lang mzscheme
+#lang racket/base
 (require "test-suite-utils.ss")
 
 (define windows-menu-prefix 
@@ -48,10 +48,10 @@
  'one-frame-registered
  (lambda (x) (equal? x (list "test" "first")))
  (lambda ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     `(send (make-object frame:basic% "test") show #t))
    (wait-for-frame "test")
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     `(begin0 (map (lambda (x) (send x get-label))
                   (send (group:get-the-frame-group) get-frames))
              (send (get-top-level-focus-window) close)))))
@@ -60,13 +60,13 @@
  'two-frames-registered
  (lambda (x) (equal? x (list "test2" "test1" "first")))
  (lambda ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     '(send (make-object frame:basic% "test1") show #t))
    (wait-for-frame "test1")
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     '(send (make-object frame:basic% "test2") show #t))
    (wait-for-frame "test2")
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     `(begin0 (let ([frames (send (group:get-the-frame-group) get-frames)])
                (for-each (lambda (x)
                            (unless (equal? (send x get-label) "first")
@@ -78,15 +78,15 @@
  'one-frame-unregistered
  (lambda (x) (equal? x (list "test1" "first")))
  (lambda ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     '(send (make-object frame:basic% "test1") show #t))
    (wait-for-frame "test1")
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     '(send (make-object frame:basic% "test2") show #t))
    (wait-for-frame "test2")
    (queue-sexp-to-mred
     `(send (get-top-level-focus-window) close))
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     `(let ([frames (send (group:get-the-frame-group) get-frames)])
        (for-each (lambda (x)
                    (unless (equal? (send x get-label) "first")
@@ -101,11 +101,11 @@
    (lambda (x)
      (equal? x (append windows-menu-prefix (list "first" "test"))))
    (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       '(let ([frame (make-object frame:basic% "test")])
          (send frame show #t)))
      (wait-for-frame "test")
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       '(begin0 (map (lambda (x)
                       (and (is-a? x labelled-menu-item<%>) (send x get-label)))
                     (send (car* (send (send (get-top-level-focus-window)
@@ -119,12 +119,12 @@
    (lambda (x)
      (equal? x (append windows-menu-prefix (list "first" "test"))))
    (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       '(let ([frame1 (make-object frame:basic% "test")]
              [frame2 (make-object frame:basic% "test-not-shown")])
          (send frame1 show #t)))
      (wait-for-frame "test")
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       '(begin0 (map (lambda (x)
                       (and (is-a? x labelled-menu-item<%>) (send x get-label)))
                     (send (car* (send (send (get-top-level-focus-window)
@@ -138,15 +138,15 @@
    (lambda (x)
      (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
    (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       '(let ([frame (make-object frame:basic% "aaa")])
          (send frame show #t)))
      (wait-for-frame "aaa")
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       '(let ([frame (make-object frame:basic% "bbb")])
          (send frame show #t)))
      (wait-for-frame "bbb")
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       `(let ([frames (send (group:get-the-frame-group) get-frames)])
          (begin0 (map (lambda (x)
                         (and (is-a? x labelled-menu-item<%>) (send x get-label)))
@@ -163,15 +163,15 @@
    (lambda (x)
      (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
    (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       '(let ([frame (make-object frame:basic% "bbb")])
          (send frame show #t)))
      (wait-for-frame "bbb")
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       '(let ([frame (make-object frame:basic% "aaa")])
          (send frame show #t)))
      (wait-for-frame "aaa")
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       `(let ([frames (send (group:get-the-frame-group) get-frames)])
          (begin0 (map (lambda (x)
                         (and (is-a? x labelled-menu-item<%>) (send x get-label)))
diff --git a/collects/tests/framework/keys.rkt b/collects/tests/framework/keys.rkt
index 2ff6c5fa50..8b3f0a6c18 100644
--- a/collects/tests/framework/keys.rkt
+++ b/collects/tests/framework/keys.rkt
@@ -1,13 +1,13 @@
-(module keys mzscheme
-  (require "test-suite-utils.ss")
-  (require mzlib/include)
+#lang racket/base
+
+(require "test-suite-utils.ss")
   
   (test
    'keymap:aug-keymap%/get-table
    (lambda (x)
      (equal? '((c:k "abc")) x))
    (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       '(let ([k (make-object keymap:aug-keymap%)])
          (send k add-function "abc" void)
          (send k map-function "c:k" "abc")
@@ -18,7 +18,7 @@
    (lambda (x)
      (equal? x '((c:k "def"))))
    (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       '(let ([k (make-object keymap:aug-keymap%)]
              [ht (make-hasheq)])
          (send k add-function "abc" void)
@@ -31,7 +31,7 @@
    (lambda (x)
      (equal? x '((c:k "abc-k2"))))
    (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       '(let ([k (make-object keymap:aug-keymap%)]
              [k1 (make-object keymap:aug-keymap%)]
              [k2 (make-object keymap:aug-keymap%)])
@@ -48,7 +48,7 @@
    (lambda (x)
      (equal? x '((c:k "abc-k"))))
    (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       '(let ([k (make-object keymap:aug-keymap%)]
              [k1 (make-object keymap:aug-keymap%)])
          (send k1 add-function "abc-k1" void)
@@ -64,7 +64,7 @@
      (lambda (x)
        (string=? x str2))
      (lambda ()
-       (send-sexp-to-mred
+       (queue-sexp-to-mred
         `(keymap:canonicalize-keybinding-string ,str2)))))
   
   (test-canonicalize 1 "c:a" "c:a")
@@ -260,13 +260,13 @@
       (list '((#\c control) (#\[ control))))
      ))
   
-  (send-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #t))
-  (send-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))
+  (queue-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #t))
+  (queue-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))
   (wait-for-frame "dummy to trick frame group")
   
   ;; test-key : key-spec -> 
   ;;   evaluates a test case represented as a key-spec
-  (define (test-key key-spec)
+  (define (test-key key-spec i)
     (let* ([key-sequences 
             ((case (system-type)
                [(macos macosx) key-spec-macos]
@@ -280,7 +280,7 @@
               (let ([text-expect (buff-spec-string after)]
                     [start-expect (buff-spec-start after)]
                     [end-expect (buff-spec-end after)])
-                (test key-sequence
+                (test (list key-sequence i)
                       (lambda (x) (equal? x (vector text-expect start-expect end-expect)))
                       `(let* ([text (send (get-top-level-focus-window) get-editor)])
                          (send text erase)
@@ -295,15 +295,16 @@
   
   
   (define (test-specs frame-name frame-class specs)
-    (send-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t))
+    (queue-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t))
     (wait-for-frame frame-name)
-    (for-each test-key specs)
-    (send-sexp-to-mred `(send (get-top-level-focus-window) close)))
+    (for ([spec (in-list specs)]
+          [i (in-naturals)])
+      (test-key spec i))
+    (queue-sexp-to-mred `(send (get-top-level-focus-window) close)))
   
   (test-specs "global keybindings test" 'frame:text% global-specs)
   (test-specs "scheme mode keybindings test" 
               '(class frame:editor%
                  (define/override (get-editor%) scheme:text%)
                  (super-new))
-              scheme-specs))
-
+              scheme-specs)
diff --git a/collects/tests/framework/load.rkt b/collects/tests/framework/load.rkt
index 4b37088d1a..d73d44e4cb 100644
--- a/collects/tests/framework/load.rkt
+++ b/collects/tests/framework/load.rkt
@@ -1,5 +1,5 @@
-(module load mzscheme
-  (require "test-suite-utils.ss")
+#lang racket/base
+(require "test-suite-utils.ss")
 
   (load-framework-automatically #f)
 
@@ -47,4 +47,4 @@
                          (with-syntax ([eles eles])
                            #''eles))])))
            (eval '(require framework/framework-sig))
-           (eval '(for-each eval (signature->symbols framework^))))))
+           (eval '(for-each eval (signature->symbols framework^)))))
diff --git a/collects/tests/framework/mem.rkt b/collects/tests/framework/mem.rkt
index 3e35e33bc4..47cd866314 100644
--- a/collects/tests/framework/mem.rkt
+++ b/collects/tests/framework/mem.rkt
@@ -1,4 +1,4 @@
-#lang mzscheme
+#lang racket/base
 (require "test-suite-utils.ss")
 
 ; mem-boxes : (list-of (list string (list-of (weak-box TST))))
@@ -7,7 +7,7 @@
 (define mem-count 10)
 
 (define (test-allocate tag open close)
-  (send-sexp-to-mred
+  (queue-sexp-to-mred
    `(let ([new-boxes
            (let loop ([n ,mem-count])
              (cond
@@ -32,7 +32,7 @@
       (set! mem-boxes (cons (list ,tag new-boxes) mem-boxes)))))
 
 (define (done)
-  (send-sexp-to-mred
+  (queue-sexp-to-mred
    `(begin
       (yield) (collect-garbage)
       (yield) (collect-garbage)
@@ -110,7 +110,7 @@
 
 (define (test-frame-allocate %)
   (let ([name (format "~s" %)])
-    (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f))
+    (queue-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f))
     (test-allocate name
                    `(lambda ()
                       (let ([f (make-object ,% ,name)])
@@ -123,7 +123,7 @@
                       (when (send f is-shown?)
                         (error 'test-frame-allocate "~a instance didn't close" ',%))
                       (yield) (yield)))
-    (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t))))
+    (queue-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t))))
 
 (test-allocate "frame%"
                '(lambda ()
diff --git a/collects/tests/framework/panel-single.rkt b/collects/tests/framework/panel-single.rkt
index 899df78fb5..ee1936c190 100644
--- a/collects/tests/framework/panel-single.rkt
+++ b/collects/tests/framework/panel-single.rkt
@@ -1,134 +1,135 @@
-#lang mzscheme
+#lang racket/base
 (require "test-suite-utils.ss")
 
 (test 
  'single-panel
  (lambda (x) (eq? x 'passed))
- `(let* ([semaphore (make-semaphore 0)]
-	 [semaphore-frame%
-	  (class frame% 
-	    (define/augment (on-close) (semaphore-post semaphore))
-	    (super-new))]
-	 [f (make-object semaphore-frame% "Single Panel Test")]
-	 [blue-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)]
-	 [green-brush (send the-brush-list find-or-create-brush "FOREST GREEN" 'solid)]
-	 [black-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid)]
-	 [grid-canvas%
-	  (class canvas% 
-	    (init-field lines)
-	    (init label)
-	    (inherit get-dc get-client-size)
-	    (override on-paint)
-	    (define (on-paint)
-	      (let-values ([(width height) (get-client-size)])
-		(let ([dc (get-dc)]
-		      [single-width (/ width lines)]
-		      [single-height (/ height lines)])
-		  (send dc set-pen black-pen)
-		  (let loop ([i lines])
-		    (cond
-		      [(zero? i) (void)]
-		      [else
-		       (let loop ([j lines])
-			 (cond
-			   [(zero? j) (void)]
-			   [else 
-			    (send dc set-brush
-				  (if (= 0 (modulo (+ i j) 2))
-				      blue-brush green-brush))
-			    (send dc draw-rectangle
-				  (* single-width (- i 1))
-				  (* single-height (- j 1))
-				  single-width
-				  single-height)
-			    (loop (- j 1))]))
-		       (loop (- i 1))])))))
-	    (super-instantiate ())
-
-	    ;; soon to be obsolete, hopefully.
-	    (inherit set-label)
-	    (set-label label)
-
-	    (inherit min-width min-height)
-	    (min-width 50)
-	    (min-height 50))]
-	 [border-panel (make-object horizontal-panel% f '(border))]
-	 [single-panel (make-object panel:single% border-panel)]
-	 [children
-	  (list
-	   (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Small") (stretchable-width #f) (stretchable-height #f))
-	   (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Wide") (stretchable-width #f) (stretchable-height #t))
-	   (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Tall") (stretchable-width #t) (stretchable-height #f))
-	   (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Wide and Tall") (stretchable-width #t) (stretchable-height #t)))]
-	 [active-child (car children)]
-	 [radios (make-object horizontal-panel% f)]
-	 [make-radio
-	  (lambda (label choices callback)
-	    (let* ([panel (make-object vertical-panel% radios '(border))]
-		   [message (make-object message% label panel)]
-		   [radio (make-object radio-box% #f choices panel (lambda (radio _) (callback radio)))]
-		   [button (make-object button%
-			     "Cycle" panel
-			     (lambda (_1 _2)
-			       (let ([before (send radio get-selection)]
-				     [tot (send radio get-number)])
-				 (let loop ([n tot])
-				   (unless (zero? n)
-				     (send radio set-selection (- tot n))
-				     (callback radio)
-				     (sleep/yield 1)
-				     (loop (- n 1))))
-				 (send radio set-selection before)
-				 (callback radio))))])
-	      radio))]
-	 [radio
-	  (make-radio
-	   "Active Child"
-	   (map (lambda (x) (send x get-label)) children)
-	   (lambda (radio)
-	     (let loop ([n (length children)]
-			[cs children])
-	       (cond
-		 [(null? cs) (void)]
-		 [else (let ([c (car cs)])
-			 (if (string=? (send radio get-item-label (send radio get-selection))
-				       (send c get-label))
-			     (begin (set! active-child c)
-				    (send single-panel active-child active-child))
-			     (loop (- n 1)
-				   (cdr cs))))]))))]
-	 [vertical-alignment 'center]
-	 [horizontal-alignment 'center]
-	 [update-alignment (lambda () 
-			     (send single-panel set-alignment horizontal-alignment vertical-alignment))]
-	 [horiz
-	  (make-radio 
-	   "Horizontal Alignment"
-	   (list "left" "center" "right")
-	   (lambda (radio)
-	     (set! horizontal-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
-	     (update-alignment)))]
-	 [vert
-	  (make-radio
-	   "Vertical Alignment"
-	   (list "top" "center" "bottom")
-	   (lambda (radio)
-	     (set! vertical-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
-	     (update-alignment)))]
-	 [buttons (make-object horizontal-panel% f)]
-	 [result 'failed]
-	 [failed (make-object button% "Failed" buttons (lambda (_1 _2) (semaphore-post semaphore)))]
-	 [passed (make-object button% "Passed" buttons (lambda (_1 _2) 
-							 (set! result 'passed)
-							 (semaphore-post semaphore)))])
-    (send border-panel min-width 100)
-    (send border-panel min-height 100)
-    (send vert set-selection 1)
-    (send horiz set-selection 1)
-    (send buttons stretchable-height #f)
-    (send buttons set-alignment 'right 'center)
-    (send radios stretchable-height #f)
-    (send f show #t)
-    (yield semaphore)
-    (send f show #f)
-    result))
+ (λ ()
+   (queue-sexp-to-mred
+    `(let* ([semaphore (make-semaphore 0)]
+            [semaphore-frame%
+             (class frame% 
+               (define/augment (on-close) (semaphore-post semaphore))
+               (super-new))]
+            [f (make-object semaphore-frame% "Single Panel Test")]
+            [blue-brush (send the-brush-list find-or-create-brush "navy" 'solid)]
+            [green-brush (send the-brush-list find-or-create-brush "lightblue" 'solid)]
+            [grid-canvas%
+             (class canvas% 
+               (init-field lines)
+               (init label)
+               (inherit get-dc get-client-size)
+               (override on-paint)
+               (define (on-paint)
+                 (let-values ([(width height) (get-client-size)])
+                   (let ([dc (get-dc)]
+                         [single-width (/ width lines)]
+                         [single-height (/ height lines)])
+                     (send dc set-pen "black" 1 'transparent)
+                     (let loop ([i lines])
+                       (cond
+                         [(zero? i) (void)]
+                         [else
+                          (let loop ([j lines])
+                            (cond
+                              [(zero? j) (void)]
+                              [else 
+                               (send dc set-brush
+                                     (if (= 0 (modulo (+ i j) 2))
+                                         blue-brush green-brush))
+                               (send dc draw-rectangle
+                                     (* single-width (- i 1))
+                                     (* single-height (- j 1))
+                                     single-width
+                                     single-height)
+                               (loop (- j 1))]))
+                          (loop (- i 1))])))))
+               (super-instantiate ())
+               
+               ;; soon to be obsolete, hopefully.
+               (inherit set-label)
+               (set-label label)
+               
+               (inherit min-width min-height)
+               (min-width 50)
+               (min-height 50))]
+            [border-panel (make-object horizontal-panel% f '(border))]
+            [single-panel (make-object panel:single% border-panel)]
+            [children
+             (list
+              (new grid-canvas% (lines 3) (parent single-panel) (label "Small") (stretchable-width #f) (stretchable-height #f))
+              (new grid-canvas% (lines 3) (parent single-panel) (label "Wide") (stretchable-width #t) (stretchable-height #f))
+              (new grid-canvas% (lines 3) (parent single-panel) (label "Tall") (stretchable-width #f) (stretchable-height #t))
+              (new grid-canvas% (lines 3) (parent single-panel) (label "Wide and Tall") (stretchable-width #t) (stretchable-height #t)))]
+            [active-child (car children)]
+            [radios (make-object horizontal-panel% f)]
+            [make-radio
+             (lambda (label choices callback)
+               (let* ([panel (make-object vertical-panel% radios '(border))]
+                      [message (make-object message% label panel)]
+                      [radio (make-object radio-box% #f choices panel (lambda (radio _) (callback radio)))]
+                      [button (make-object button%
+                                "Cycle" panel
+                                (lambda (_1 _2)
+                                  (let ([before (send radio get-selection)]
+                                        [tot (send radio get-number)])
+                                    (let loop ([n tot])
+                                      (unless (zero? n)
+                                        (send radio set-selection (- tot n))
+                                        (callback radio)
+                                        (sleep/yield 1)
+                                        (loop (- n 1))))
+                                    (send radio set-selection before)
+                                    (callback radio))))])
+                 radio))]
+            [radio
+             (make-radio
+              "Active Child"
+              (map (lambda (x) (send x get-label)) children)
+              (lambda (radio)
+                (let loop ([n (length children)]
+                           [cs children])
+                  (cond
+                    [(null? cs) (void)]
+                    [else (let ([c (car cs)])
+                            (if (string=? (send radio get-item-label (send radio get-selection))
+                                          (send c get-label))
+                                (begin (set! active-child c)
+                                       (send single-panel active-child active-child))
+                                (loop (- n 1)
+                                      (cdr cs))))]))))]
+            [vertical-alignment 'center]
+            [horizontal-alignment 'center]
+            [update-alignment (lambda () 
+                                (send single-panel set-alignment horizontal-alignment vertical-alignment))]
+            [horiz
+             (make-radio 
+              "Horizontal Alignment"
+              (list "left" "center" "right")
+              (lambda (radio)
+                (set! horizontal-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
+                (update-alignment)))]
+            [vert
+             (make-radio
+              "Vertical Alignment"
+              (list "top" "center" "bottom")
+              (lambda (radio)
+                (set! vertical-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
+                (update-alignment)))]
+            [buttons (make-object horizontal-panel% f)]
+            [result 'failed]
+            [failed (make-object button% "Failed" buttons (lambda (_1 _2) (semaphore-post semaphore)))]
+            [passed (make-object button% "Passed" buttons (lambda (_1 _2) 
+                                                            (set! result 'passed)
+                                                            (semaphore-post semaphore)))])
+       (send border-panel min-width 100)
+       (send border-panel min-height 100)
+       (send vert set-selection 1)
+       (send horiz set-selection 1)
+       (send buttons stretchable-height #f)
+       (send buttons set-alignment 'right 'center)
+       (send radios stretchable-height #f)
+       (send f show #t)
+       (yield semaphore)
+       (send f show #f)
+       result))))
diff --git a/collects/tests/framework/pasteboard.rkt b/collects/tests/framework/pasteboard.rkt
index 59a0d3c923..9eea4590fc 100644
--- a/collects/tests/framework/pasteboard.rkt
+++ b/collects/tests/framework/pasteboard.rkt
@@ -1,5 +1,5 @@
-(module pasteboard mzscheme
-  (require "test-suite-utils.ss")
+#lang racket/base
+(require "test-suite-utils.ss")
 
 (define (test-creation frame class name)
   (test
@@ -7,12 +7,10 @@
    (lambda (x) #t)
    (lambda ()
      (let ([frame-label
-	    (send-sexp-to-mred
-	     `(let* ([% (class ,frame
-			  (override get-editor%)
-			  [define (get-editor%)
-			    ,class])]
-		     [f (instantiate % ())])
+	    (queue-sexp-to-mred
+             `(let* ([f (new (class ,frame
+                               (define/override (get-editor%) ,class)
+                               (super-new)))])
 		(preferences:set 'framework:exit-when-no-frames #f)
 		(send f show #t)
 		(send f get-label)))])
@@ -47,4 +45,3 @@
 (test-creation 'frame:pasteboard%
 	       'pasteboard:info%
 	       'pasteboard:info-creation)
-)
diff --git a/collects/tests/framework/prefs.rkt b/collects/tests/framework/prefs.rkt
index 0549464250..48da9fcfed 100644
--- a/collects/tests/framework/prefs.rkt
+++ b/collects/tests/framework/prefs.rkt
@@ -1,29 +1,11 @@
-(module prefs mzscheme
-  (require "test-suite-utils.ss"
-	   mzlib/list)
+#lang racket/base
+(require "test-suite-utils.ss")
   
   (define ((check-eq? x) y) (eq? x y))
   (define pref-sym 'plt:not-a-real-preference)
   (define marshalling-pref-sym 'plt:not-a-real-preference-marshalling)
   (define default-test-sym 'plt:not-a-real-preference-default-test)
   
-  (define saved-prefs-file
-    (let loop ([n 0])
-      (let ([candidate
-             (build-path (find-system-path 'temp-dir)
-                         (format "saved-prefs.~a" n))])
-        (if (file-exists? candidate)
-            (loop (+ n 1))
-            candidate)))) 
-  
-  (define prefs-file (find-system-path 'pref-file))
-  
-  (when (file-exists? prefs-file)
-    (copy-file prefs-file saved-prefs-file)
-    (delete-file prefs-file)
-    (debug-printf admin "saved preferences file from ~s\n" prefs-file)
-    (debug-printf admin "                         to ~s\n" saved-prefs-file))
-  
   (shutdown-mred)
   
   (test
@@ -102,12 +84,4 @@
                                                 'failed
                                                 'passed)
                                             'passed))))))
-  
-  (when (file-exists? saved-prefs-file)
-    (debug-printf admin "restoring preferences file from ~s\n" saved-prefs-file)
-    (debug-printf admin "                             to ~s\n" prefs-file)
-    (when (file-exists? prefs-file)
-      (delete-file prefs-file))
-    (copy-file saved-prefs-file prefs-file)
-    (delete-file saved-prefs-file)))
-
+  
\ No newline at end of file
diff --git a/collects/tests/framework/scheme.rkt b/collects/tests/framework/scheme.rkt
index 6f5129a63b..60e1165c38 100644
--- a/collects/tests/framework/scheme.rkt
+++ b/collects/tests/framework/scheme.rkt
@@ -1,4 +1,4 @@
-#lang scheme
+#lang racket/base
 
 (require "test-suite-utils.ss")
 
@@ -14,7 +14,7 @@
    (lambda (x) 
      (equal? x expected))
    (λ ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       `(let ([t (new scheme:text%)])
          (send t insert ,str)
          (scheme:text-balanced? t ,start ,end))))))
diff --git a/collects/tests/framework/search.rkt b/collects/tests/framework/search.rkt
index ed8d5e6a91..bf636d1a80 100644
--- a/collects/tests/framework/search.rkt
+++ b/collects/tests/framework/search.rkt
@@ -1,5 +1,5 @@
-#lang scheme
-
+#lang racket/base
+(require (for-syntax racket/base))
 (require "test-suite-utils.ss")
 
 (define-syntax (test-search stx)
@@ -13,7 +13,7 @@
    (string->symbol (format "search.ss: line ~a" line))
    (lambda (x) (equal? bubble-table x))
    (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
       `(let ([t (new (text:searching-mixin (editor:keymap-mixin text:basic%)))]
              [normalize
               (λ (ht) (sort (hash-table-map ht list)
diff --git a/collects/tests/framework/test-suite-utils.rkt b/collects/tests/framework/test-suite-utils.rkt
index 2bd63538c0..dd5ec2007e 100644
--- a/collects/tests/framework/test-suite-utils.rkt
+++ b/collects/tests/framework/test-suite-utils.rkt
@@ -1,8 +1,10 @@
-#lang scheme
+#lang racket/base
 
 (require (only-in mzscheme fluid-let)
          launcher
-         scheme/system
+         racket/system
+         racket/tcp
+         racket/pretty
          "debug.ss")
 
 (provide
@@ -140,11 +142,10 @@
 (define queue-sexp-to-mred
   (lambda (sexp)
     (send-sexp-to-mred
-     `(let ([thunk (lambda () ,sexp)]  ;; lotech hygiene
+     `(let ([thunk (lambda () ,sexp)]  ;; low tech hygiene
             [c (make-channel)])
         (queue-callback (lambda () (channel-put c (thunk))))
-        (channel-wait c)))))
-
+        (channel-get c)))))
 
 (define re:tcp-read-error (regexp "tcp-read:"))
 (define re:tcp-write-error (regexp "tcp-write:"))
@@ -152,7 +153,7 @@
   (or (regexp-match re:tcp-read-error (exn-message exn))
       (regexp-match re:tcp-write-error (exn-message exn))))
 
-(namespace-require 'scheme) ;; in order to make the eval below work right.
+(namespace-require 'racket) ;; in order to make the eval below work right.
 (define (send-sexp-to-mred sexp)
   (let/ec k
     (let ([show-text
@@ -225,12 +226,12 @@
             (raise (make-eof-result))
             (case (car answer)
               [(error)
-               (error 'send-sexp-to-mred "gracket raised \"~a\"" (second answer))]
+               (error 'send-sexp-to-mred "gracket raised \"~a\"" (list-ref answer 1))]
               [(last-error)
-               (error 'send-sexp-to-mred "gracket (last time) raised \"~a\"" (second answer))]
-              [(cant-read) (error 'mred/cant-parse (second answer))]
+               (error 'send-sexp-to-mred "gracket (last time) raised \"~a\"" (list-ref answer 1))]
+              [(cant-read) (error 'mred/cant-parse (list-ref answer 1))]
               [(normal) 
-               (eval (second answer))]))))))
+               (eval (list-ref answer 1))]))))))
 
 (define test
   (case-lambda
@@ -286,7 +287,15 @@
                  (sleep ,pause-time)
                  (loop (- n 1))))))))))
 
-(define (wait-for sexp) (wait-for/wrapper (lambda (x) x) sexp))
+(define (wait-for sexp #:queue? [queue? #f]) 
+  (wait-for/wrapper
+   (lambda (x) x)
+   (if queue?
+       `(let ([t (λ () ,sexp)]
+              [c (make-channel)])
+          (queue-callback (λ () (channel-put c (t))))
+          (channel-get c))
+       sexp)))
 
 (define (wait-for-new-frame sexp)
   (wait-for/wrapper
diff --git a/collects/tests/framework/text.rkt b/collects/tests/framework/text.rkt
index f0047ebfa2..25dbaa5e6e 100644
--- a/collects/tests/framework/text.rkt
+++ b/collects/tests/framework/text.rkt
@@ -1,9 +1,10 @@
-#lang scheme
+#lang racket/base
 
-(require "test-suite-utils.ss")
+(require racket/file
+         "test-suite-utils.ss")
 
 (define dummy-frame-title "dummy to avoid quitting")
-(send-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t))
+(queue-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t))
 
 (define (test-creation frame% class name)
   (test
@@ -12,29 +13,26 @@
      (equal? x (list dummy-frame-title))) ;; ensure no frames left
    (lambda ()
      (let ([label
-            (send-sexp-to-mred
-             `(let ([f (instantiate (class ,frame%
-                                      (override get-editor%)
-                                      [define (get-editor%) ,class]
-                                      (super-instantiate ()))
-                         ())])
+            (queue-sexp-to-mred
+             `(let ([f (new (class ,frame%
+                              (define/override (get-editor%) ,class)
+                              (super-new)))])
                 (send (send f get-editor) set-max-undo-history 10)
                 (send f show #t)
                 (send f get-label)))])
        (wait-for-frame label)
        (send-sexp-to-mred `(test:keystroke #\a))
-       (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text)))
-       (send-sexp-to-mred
+       (wait-for #:queue? #t `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text)))
+       (queue-sexp-to-mred
         `(begin 
            ;; remove the `a' to avoid save dialog boxes (and test them, I suppose)
            (send (send (get-top-level-focus-window) get-editor) undo) 
            (send (send (get-top-level-focus-window) get-editor) undo)
            
            (send (send (get-top-level-focus-window) get-editor) lock #t)
-           (send (send (get-top-level-focus-window) get-editor) lock #f)))
-       (queue-sexp-to-mred
-        `(send (get-top-level-focus-window) close))
-       (send-sexp-to-mred `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))))
+           (send (send (get-top-level-focus-window) get-editor) lock #f)
+           (send (get-top-level-focus-window) close)))
+       (queue-sexp-to-mred `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))))
 
 #|
   (test-creation 'frame:text%
@@ -88,7 +86,7 @@
  'highlight-range1
  (lambda (x) (equal? x 1))
  (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     `(let ([t (new text:basic%)])
        (send t insert "abc")
        (send t highlight-range 1 2 "red")
@@ -98,7 +96,7 @@
  'highlight-range2
  (lambda (x) (equal? x 0))
  (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     `(let ([t (new text:basic%)])
        (send t insert "abc")
        ((send t highlight-range 1 2 "red"))
@@ -109,7 +107,7 @@
  'highlight-range3
  (lambda (x) (equal? x 0))
  (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     `(let ([t (new text:basic%)])
        (send t insert "abc")
        (send t highlight-range 1 2 "red")
@@ -121,7 +119,7 @@
  'highlight-range4
  (lambda (x) (equal? x 1))
  (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     `(let ([t (new text:basic%)])
        (send t insert "abc")
        (send t highlight-range 1 2 "red")
@@ -135,7 +133,7 @@
  'highlight-range5
  (lambda (x) (equal? x 0))
  (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     `(let ([t (new text:basic%)])
        (send t insert "abc")
        (send t highlight-range 1 2 "red")
@@ -151,7 +149,7 @@
      (delete-file tmp-file)
      (equal? x 0))
    (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     `(let ([t (new text:basic%)])
        (send t insert "abc")
        (send t save-file ,tmp-file)
@@ -172,7 +170,7 @@
  'print-to-dc
  (λ (x) (equal? x 'no-error))
  (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     '(let* ([t (new text:basic%)]
             [bmp (make-object bitmap% 100 40)]
             [dc (new bitmap-dc% (bitmap bmp))])
@@ -186,7 +184,7 @@
  'print-to-dc2
  (λ (x) (equal? x 'no-error))
  (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
     `(let* ([f (new frame% [label ""])]
             [t (new text:basic%)]
             [ec (new editor-canvas% [parent f] [editor t])]
@@ -197,4 +195,4 @@
        (send f reflow-container)
        (send dc clear)
        (send t print-to-dc dc 1)
-       'no-error))))
\ No newline at end of file
+       'no-error))))