diff --git a/collects/2htdp/private/universe.ss b/collects/2htdp/private/universe.ss
index 17b5263732..7fc5426de7 100644
--- a/collects/2htdp/private/universe.ss
+++ b/collects/2htdp/private/universe.ss
@@ -31,7 +31,8 @@
   (last-mixin
    (clock-mixin
     (class* object% (start-stop<%>) (inspect #f) (super-new)
-      (init-field        ;; type Result = (make-bundle Universe [Listof Mail])
+      (init-field        ;; type Result
+                         ; = (make-bundle [Listof World] Universe [Listof Mail])
        universe0         ;; the initial state of the universe
        on-new            ;; Universe World -> Result
        on-msg            ;; Universe World Message -> Result
@@ -56,10 +57,11 @@
           (define (pname a ...) 
             (define (handler e) (stop! e))
             (with-handlers ([exn? handler])
-              (define r (check-state-x-mail 'name (name universe a ...)))
+              (define r (check-state-x-mail 'name (name worlds universe a ...)))
               (define u (bundle-state r))
+              (set! worlds (bundle-low r))
               (set! universe u)
-              (unless (boolean? to-string) (send gui add (to-string u)))
+              (unless (boolean? to-string) (send gui add (to-string worlds u)))
               (broadcast (bundle-mails r))))))
       
       (def/cback private (pmsg world received) on-msg)
@@ -68,9 +70,9 @@
       
       (def/cback private (pnew world) ppnew)
       
-      (define/private (ppnew uni p)
+      (define/private (ppnew low uni p)
         (world-send p 'okay)
-        (on-new uni p))
+        (on-new low uni p))
       
       (def/cback public (ptock) tick)
       
@@ -80,8 +82,9 @@
       (define/private (check-state-x-mail tag r)
         (with-handlers ((exn? (lambda (x) (stop! x))))
           (define s (format "expected from ~a, given: " tag))
+          (define f "(make-bundle [Listof World] Universe [Listof Mail]) ~a~e")
           (unless (bundle? r) 
-            (error tag (format "(make-bundle Universe [Listof Mail]) ~a~e" s r)))
+            (error tag (format f s r)))
           r))
       
       ;; -----------------------------------------------------------------------
@@ -109,7 +112,7 @@
               (match next
                 [(cons 'REGISTER info)
                  (let* ([w (create-world in (second in-out) info)])
-                   (set! worlds (cons w worlds))
+                   ; (set! worlds (cons w worlds))
                    (pnew w)
                    (send gui add (format "~a signed up" info))
                    (loop))]
@@ -216,6 +219,7 @@
 (provide 
  world?  ;; Any -> Boolean 
  world=? ;; World World -> Boolean 
+ world-name ;; World -> Symbol 
  world1  ;; sample worlds 
  world2
  world3)
@@ -334,24 +338,30 @@
 ;                              
 
 (provide
- ;; type Bundle = (make-bundle Universe [Listof Mail]) 
+ ;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail]) 
  ;; type Mail = (make-mail World S-expression)
- make-bundle ;; Universe [Listof Mail] -> Bundle 
+ make-bundle ;; [Listof World] Universe [Listof Mail] -> Bundle 
  bundle?     ;; is this a bundle? 
  make-mail   ;; World S-expression -> Mail 
  mail?       ;; is this a real mail? 
  )
 
-(define-struct bundle (state mails) #:transparent)
+(define-struct bundle (low state mails) #:transparent)
 
 (set! make-bundle
       (let ([make-bundle make-bundle])
-        (lambda (state mails)
-          (check-arg 'make-bundle (list? mails) "list [of mails]" "second" mails)
-          (for-each (lambda (c) 
-                      (check-arg 'make-bundle (mail? c) "mail" "(elements of) second" c))
-                    mails)
-          (make-bundle state mails))))
+        (lambda (low state mails)
+          (check-arg-list 'make-bundle low world? "world" "first")
+          (check-arg-list 'make-bundle mails mail? "mail" "third")
+          (make-bundle low state mails))))
+
+;; Symbol Any (Any -> Boolean) String String -> Void 
+;; raise a TP exception if low is not a list of world? elements 
+(define (check-arg-list tag low world? msg rank)
+  (check-arg tag (list? low) (format "list [of ~as]" msg) rank low)
+  (for-each (lambda (c) 
+              (check-arg tag (world? c) msg (format "(elements of) ~a" rank) c))
+            low))
 
 (define-struct mail (to content) #:transparent)
 
diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss
index 2270aafeb1..6daa9e326f 100644
--- a/collects/2htdp/private/world.ss
+++ b/collects/2htdp/private/world.ss
@@ -278,7 +278,8 @@
       ;; -------------------------------------------------------------------------
       ;; initialize the world and run 
       (super-new)
-      (start!)))))
+      (start!)
+      (when (stop-when world) (stop! world))))))
 
 ;; -----------------------------------------------------------------------------
 (define-runtime-path break-btn:path '(lib "icons/break.png"))
@@ -293,16 +294,17 @@
     (inherit-field world0 tick key mouse rec draw rate width height)
     (inherit show callback-stop!)
     
-    ;; Frame Custodian -> (-> Void)
+    ;; Frame Custodian ->* (-> Void) (-> Void)
     ;; adds the stop animation and image creation button, 
     ;; whose callbacks runs as a thread in the custodian
-    ;; provide a function for switching button enabling 
     (define/augment (create-frame frm play-back-custodian)
       (define p (new horizontal-pane% [parent frm][alignment '(center center)]))
       (define (switch)
         (send stop-button enable #f)
         (send image-button enable #t))
-      (define (stop) (send stop-button enable #f))
+      (define (stop) 
+        (send image-button enable #f)
+        (send stop-button enable #f))
       (define-syntax-rule (btn l a y ...)
         (new button% [parent p] [label l] [style '(border)] 
              [callback (lambda a y ...)]))
diff --git a/collects/2htdp/test/world0-stops.ss b/collects/2htdp/test/world0-stops.ss
new file mode 100644
index 0000000000..a50c191bf2
--- /dev/null
+++ b/collects/2htdp/test/world0-stops.ss
@@ -0,0 +1,5 @@
+;; The first three lines of this file were inserted by DrScheme. They record metadata
+;; about the language level of this file in a form that our tools can easily process.
+#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world0-stops) (read-case-sensitive #t) (teachpacks ((lib "universe.ss" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "universe.ss" "teachpack" "2htdp")))))
+
+(big-bang 0 (stop-when zero?) (on-tick add1))
\ No newline at end of file
diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss
index 33801da892..f8182421f8 100644
--- a/collects/2htdp/universe.ss
+++ b/collects/2htdp/universe.ss
@@ -228,12 +228,13 @@
  ;; type World 
  world?    ;; Any -> Boolean 
  world=?   ;; World World -> Boolean 
+ world-name ;; World -> Symbol 
  world1    ;; sample worlds 
  world2
  world3
- ;; type Bundle = (make-bundle Universe [Listof Mail]) 
+ ;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail]) 
  ;; type Mail = (make-mail World S-expression)
- make-bundle ;; Universe [Listof Mail] -> Bundle 
+ make-bundle ;; [Listof World] Universe [Listof Mail] -> Bundle 
  bundle?     ;; is this a bundle? 
  make-mail   ;; World S-expression -> Mail 
  mail?       ;; is this a real mail? 
@@ -254,10 +255,10 @@
 ;;    in the console 
 
 (define-keywords UniSpec
-  [on-new (function-with-arity 2)]
-  [on-msg (function-with-arity 3)]
-  [on-disconnect (function-with-arity 2)]
-  [to-string (function-with-arity 1)])
+  [on-new (function-with-arity 3)]
+  [on-msg (function-with-arity 4)]
+  [on-disconnect (function-with-arity 3)]
+  [to-string (function-with-arity 2)])
 
 (define-syntax (universe stx)
   (syntax-case stx ()
@@ -297,15 +298,15 @@
 ;; (World World -> U) (U World Msg) -> U
 (define (universe2 create process)
   ;; UniState = '() | (list World) | Universe
-  ;; UniState World -> (cons UniState [Listof (list World S-expression)])
-  (define (nu s p)
+  ;; [Listof World] UniState World -> (cons UniState [Listof (list World S-expression)])
+  (define (nu s x p)
     (cond
-      [(null? s) (make-bundle (list p) '())]
-      [(not (pair? s)) (make-bundle s '())]
+      [(null? s) (make-bundle (list p) '* '())]
+      [(not (pair? s)) (make-bundle s '* '())]
       [(null? (rest s)) (create (first s) p)]
       [else (error 'create "a third world is signing up!")]))
   (universe '() 
             (on-new nu)
             (on-msg process)
             #;
-            (on-tick (lambda (u) (printf "hello!\n") (list u)) 1)))
\ No newline at end of file
+            (on-tick (lambda (u x) (printf "hello!\n") (list u)) 1)))
\ No newline at end of file
diff --git a/collects/compiler/compiler-unit.ss b/collects/compiler/compiler-unit.ss
index b46c4ae3c3..57fc93c465 100644
--- a/collects/compiler/compiler-unit.ss
+++ b/collects/compiler/compiler-unit.ss
@@ -5,9 +5,6 @@
 ;;  by dynamically linking to code supplied by the MzLib, dynext, and
 ;;  compiler collections.
 
-;; The Scheme->C compiler is loaded as either sploadr.ss (link in
-;;  real MrSpidey) or loadr.ss (link in trivial MrSpidey stubs).
-
 #lang scheme/base
 
 (require scheme/unit
diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss
index 79ade18f4d..06e04ff2ed 100644
--- a/collects/macro-debugger/syntax-browser/display.ss
+++ b/collects/macro-debugger/syntax-browser/display.ss
@@ -9,34 +9,68 @@
 (provide print-syntax-to-editor
          code-style)
 
-;; print-syntax-to-editor : syntax text controller<%> -> display<%>
-(define (print-syntax-to-editor stx text controller config)
-  (new display% (syntax stx) (text text) (controller controller) (config config)))
-
 ;; FIXME: assumes text never moves
 
+;; print-syntax-to-editor : syntax text controller<%> config number number
+;;                          -> display<%>
+(define (print-syntax-to-editor stx text controller config columns insertion-point)
+  (define output-port (open-output-string/count-lines))
+  (define range
+    (pretty-print-syntax stx output-port 
+                         (send controller get-primary-partition)
+                         (send config get-colors)
+                         (send config get-suffix-option)
+                         columns))
+  (define output-string (get-output-string output-port))
+  (define output-length (sub1 (string-length output-string))) ;; skip final newline
+  (fixup-parentheses output-string range)
+  (let ([display
+         (new display%
+              (text text)
+              (controller controller)
+              (config config)
+              (range range)
+              (start-position insertion-point)
+              (end-position (+ insertion-point output-length)))])
+    (send text begin-edit-sequence)
+    (send text insert output-length output-string insertion-point)
+    (add-clickbacks text range controller insertion-point)
+    (set-standard-font text config insertion-point (+ insertion-point output-length))
+    (send display initialize)
+    (send text end-edit-sequence)
+    display))
+
+;; add-clickbacks : text% range% controller<%> number -> void
+(define (add-clickbacks text range controller insertion-point)
+  (for ([range (send range all-ranges)])
+    (let ([stx (range-obj range)]
+          [start (range-start range)]
+          [end (range-end range)])
+      (send text set-clickback (+ insertion-point start) (+ insertion-point end)
+            (lambda (_1 _2 _3)
+              (send controller set-selected-syntax stx))))))
+
+;; set-standard-font : text% config number number -> void
+(define (set-standard-font text config start end)
+  (send text change-style
+        (code-style text (send config get-syntax-font-size))
+        start end))
+
 ;; display%
 (define display%
   (class* object% (display<%>)
-    (init ((stx syntax)))
     (init-field text)
     (init-field controller)
     (init-field config)
+    (init-field range)
+    (init-field start-position)
+    (init-field end-position)
 
-    (define start-anchor (new anchor-snip%))
-    (define end-anchor (new anchor-snip%))
-    (define range #f)
     (define extra-styles (make-hasheq))
 
-    ;; render-syntax : syntax -> void
-    (define/public (render-syntax stx)
-      (with-unlock text
-        (send text delete (get-start-position) (get-end-position))
-        (set! range
-              (print-syntax stx text controller config
-                            (lambda () (get-start-position))
-                            (lambda () (get-end-position))))
-        (apply-primary-partition-styles))
+    ;; initialize : -> void
+    (define/public (initialize)
+      (apply-primary-partition-styles)
       (refresh))
 
     ;; refresh : -> void
@@ -45,7 +79,7 @@
       (with-unlock text
         (send* text 
           (begin-edit-sequence)
-          (change-style unhighlight-d (get-start-position) (get-end-position)))
+          (change-style unhighlight-d start-position end-position))
         (apply-extra-styles)
         (let ([selected-syntax (send controller get-selected-syntax)])
           (apply-secondary-partition-styles selected-syntax)
@@ -53,29 +87,15 @@
         (send* text
           (end-edit-sequence))))
 
-    ;; cached-start-position : number
-    (define cached-start-position #f)
-
-    ;; get-start-position : -> number
-    (define/public-final (get-start-position)
-      (unless cached-start-position
-        (set! cached-start-position (send text get-snip-position start-anchor)))
-      cached-start-position)
-
-    ;; get-end-position : -> number
-    (define/public-final (get-end-position)
-      (send text get-snip-position end-anchor))
-
-    ;; relative->text-position : number -> number
-    ;; FIXME: might be slow to find start every time!
-    (define/public-final (relative->text-position pos)
-      (+ pos (get-start-position)))
-
-    ;; Styling
-
     ;; get-range : -> range<%>
     (define/public (get-range) range)
 
+    ;; get-start-position : -> number
+    (define/public (get-start-position) start-position)
+
+    ;; get-end-position : -> number
+    (define/public (get-end-position) end-position)
+
     ;; highlight-syntaxes : (list-of syntax) string -> void
     (define/public (highlight-syntaxes stxs hi-color)
       (let ([style-delta (highlight-style-delta hi-color #f)])
@@ -89,11 +109,50 @@
         (add-extra-styles stx (list underline-style-delta)))
       (refresh))
 
+    ;; add-extra-styles : syntax (listof style) -> void
     (define/public (add-extra-styles stx styles)
       (hash-set! extra-styles stx
                  (append (hash-ref extra-styles stx null)
                          styles)))
 
+    ;; Primary styles
+    ;; (Done once on initialization, never repeated)
+
+    ;; apply-primary-partition-styles : -> void
+    ;; Changes the foreground color according to the primary partition.
+    ;; Only called once, when the syntax is first drawn.
+    (define/private (apply-primary-partition-styles)
+      (define (color-style color)
+        (let ([delta (new style-delta%)])
+          (send delta set-delta-foreground color)
+          delta))
+      (define color-styles (list->vector (map color-style (send config get-colors))))
+      (define overflow-style (color-style "darkgray"))
+      (define color-partition (send controller get-primary-partition))
+      (define offset start-position)
+      (for-each
+       (lambda (range)
+         (let ([stx (range-obj range)]
+               [start (range-start range)]
+               [end (range-end range)])
+           (send text change-style
+                 (primary-style stx color-partition color-styles overflow-style)
+                 (+ offset start)
+                 (+ offset end))))
+       (send range all-ranges)))
+
+    ;; primary-style : syntax partition (vector-of style-delta%) style-delta%
+    ;;               -> style-delta%
+    (define/private (primary-style stx partition color-vector overflow)
+      (let ([n (send partition get-partition stx)])
+        (cond [(< n (vector-length color-vector))
+               (vector-ref color-vector n)]
+              [else
+               overflow])))
+
+    ;; Secondary Styling
+    ;; May change in response to user actions
+
     ;; apply-extra-styles : -> void
     ;; Applies externally-added styles (such as highlighting)
     (define/private (apply-extra-styles)
@@ -131,101 +190,35 @@
             (relative->text-position (car r))
             (relative->text-position (cdr r))))
 
-    ;; Primary styles
-
-    ;; apply-primary-partition-styles : -> void
-    ;; Changes the foreground color according to the primary partition.
-    ;; Only called once, when the syntax is first drawn.
-    (define/private (apply-primary-partition-styles)
-      (define (color-style color)
-        (let ([delta (new style-delta%)])
-          (send delta set-delta-foreground color)
-          delta))
-      (define color-styles (list->vector (map color-style (send config get-colors))))
-      (define overflow-style (color-style "darkgray"))
-      (define color-partition (send controller get-primary-partition))
-      (define offset (get-start-position))
-      (for-each
-       (lambda (range)
-         (let ([stx (range-obj range)]
-               [start (range-start range)]
-               [end (range-end range)])
-           (send text change-style
-                 (primary-style stx color-partition color-styles overflow-style)
-                 (+ offset start)
-                 (+ offset end))))
-       (send range all-ranges)))
-
-    ;; primary-style : syntax partition (vector-of style-delta%) style-delta%
-    ;;               -> style-delta%
-    (define/private (primary-style stx partition color-vector overflow)
-      (let ([n (send partition get-partition stx)])
-        (cond [(< n (vector-length color-vector))
-               (vector-ref color-vector n)]
-              [else
-               overflow])))
+    ;; relative->text-position : number -> number
+    (define/private (relative->text-position pos)
+      (+ pos start-position))
 
     ;; Initialize
     (super-new)
-    (send text insert start-anchor)
-    (send text insert end-anchor)
-    (render-syntax stx)
     (send controller add-syntax-display this)))
 
-;; print-syntax : syntax text% controller config (-> number) (-> number)
-;;                -> range%
-(define (print-syntax stx text controller config
-                      get-start-position get-end-position)
-  (define primary-partition (send controller get-primary-partition))
-  (define real-output-port (make-text-port text get-end-position))
-  (define output-port (open-output-string))
-  (define colors (send config get-colors))
-  (define suffix-option (send config get-suffix-option))
-  (define columns (send config get-columns))
-
-  (port-count-lines! output-port)
-  (let ([range (pretty-print-syntax stx output-port primary-partition 
-                                    colors suffix-option columns)])
-    (write-string (get-output-string output-port) real-output-port)
-    (let ([end (get-end-position)])
-      ;; Pretty printer always inserts final newline; we remove it here.
-      (send text delete (sub1 end) end))
-    (let ([offset (get-start-position)])
-      (fixup-parentheses text range offset)
-      (for-each
-       (lambda (range)
-         (let* ([stx (range-obj range)]
-                [start (range-start range)]
-                [end (range-end range)])
-           (send text set-clickback (+ offset start) (+ offset end)
-                 (lambda (_1 _2 _3)
-                   (send controller set-selected-syntax stx)))))
-       (send range all-ranges)))
-    ;; Set font to standard
-    (send text change-style
-          (code-style text (send config get-syntax-font-size))
-          (get-start-position)
-          (get-end-position))
-    range))
-
-;; fixup-parentheses : text range -> void
-(define (fixup-parentheses text range offset)
+;; fixup-parentheses : string range -> void
+(define (fixup-parentheses string range)
   (define (fixup r)
     (let ([stx (range-obj r)]
-          [start (+ offset (range-start r))]
-          [end (+ offset (range-end r))])
+          [start (range-start r)]
+          [end (range-end r)])
       (when (and (syntax? stx) (pair? (syntax-e stx)))
         (case (syntax-property stx 'paren-shape)
           ((#\[)
-           (replace start #\[)
-           (replace (sub1 end) #\]))
+           (string-set! string start #\[)
+           (string-set! string (sub1 end) #\]))
           ((#\{) 
-           (replace start #\{)
-           (replace (sub1 end) #\}))))))
-  (define (replace pos char)
-    (send text insert char pos (add1 pos)))
+           (string-set! string start #\{)
+           (string-set! string (sub1 end) #\}))))))
   (for-each fixup (send range all-ranges)))
 
+(define (open-output-string/count-lines)
+  (let ([os (open-output-string)])
+    (port-count-lines! os)
+    os))
+
 ;; code-style : text<%> number/#f -> style<%>
 (define (code-style text font-size)
   (let* ([style-list (send text get-style-list)]
diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss
index 2ef4287f9c..fe31a40cc2 100644
--- a/collects/macro-debugger/syntax-browser/prefs.ss
+++ b/collects/macro-debugger/syntax-browser/prefs.ss
@@ -22,9 +22,6 @@
 
 (define prefs-base%
   (class object%
-    ;; columns : number
-    (field/notify columns (new notify-box% (value 60)))
-
     ;; suffix-option : SuffixOption
     (field/notify suffix-option (new notify-box% (value 'over-limit)))
 
diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss
index d202d2e6d6..29559e1c89 100644
--- a/collects/macro-debugger/syntax-browser/widget.ss
+++ b/collects/macro-debugger/syntax-browser/widget.ss
@@ -143,7 +143,7 @@
                 (for ([binder-r (send range get-ranges binder)])
                   (for ([id-r (send range get-ranges id)])
                     (add-binding-arrow start binder-r id-r definite?)))))))
-        display))
+        (void)))
 
     (define/private (add-binding-arrow start binder-r id-r definite?)
       (if definite?
@@ -189,14 +189,17 @@
     ;; internal-add-syntax : syntax -> display
     (define/private (internal-add-syntax stx)
       (with-unlock -text
-        (let ([display (print-syntax-to-editor stx -text controller config)])
+        (let ([display
+               (print-syntax-to-editor stx -text controller config
+                                       (calculate-columns)
+                                       (send -text last-position))])
           (send* -text
             (insert "\n")
             ;;(scroll-to-position current-position)
             )
           display)))
 
-    (define/public (calculate-columns)
+    (define/private (calculate-columns)
       (define style (code-style -text (send config get-syntax-font-size)))
       (define char-width (send style get-text-width (send -ecanvas get-dc)))
       (define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss
index 4cd2f150c2..29688ba4f2 100644
--- a/collects/macro-debugger/view/frame.ss
+++ b/collects/macro-debugger/view/frame.ss
@@ -54,7 +54,6 @@
     (define/override (on-size w h)
       (send config set-width w)
       (send config set-height h)
-      (send config set-columns (send (send widget get-view) calculate-columns))
       (send widget update/preserve-view))
 
     (define warning-panel
diff --git a/collects/mred/private/editor.ss b/collects/mred/private/editor.ss
index a3b13cb453..1ecb655e25 100644
--- a/collects/mred/private/editor.ss
+++ b/collects/mred/private/editor.ss
@@ -341,24 +341,25 @@
 			((void) after-edit-sequence))
 
 	    (private*
-	     [sp (lambda (x y z f b?)
+	     [sp (lambda (x y z f b? eps?)
 		   ;; let super method report z errors:
 		   (let ([zok? (memq z '(standard postscript))])
 		     (when zok?
 		       (check-top-level-parent/false '(method editor<%> print) f))
 		     (let ([p (and zok? f (mred->wx f))])
-		       (as-exit (lambda () (super print x y z p b?))))))])
+		       (as-exit (lambda () (super print x y z p b? eps?))))))])
 
 	    (override*
 	     [print
 	      (entry-point
 	       (case-lambda 
-		[() (sp #t #t 'standard #f #t)]
-		[(x) (sp x #t 'standard #f #t)]
-		[(x y) (sp x y 'standard #f #t)]
-		[(x y z) (sp x y z #f #t)]
-		[(x y z f) (sp x y z f #t)]
-		[(x y z f b?) (sp x y z f b?)]))]
+		[() (sp #t #t 'standard #f #t #f)]
+		[(x) (sp x #t 'standard #f #t #f)]
+		[(x y) (sp x y 'standard #f #t #f)]
+		[(x y z) (sp x y z #f #t #f)]
+		[(x y z f) (sp x y z f #t #f)]
+		[(x y z f b?) (sp x y z f b? #f)]
+		[(x y z f b? eps?) (sp x y z f b? eps?)]))]
 
 	     [on-new-box
 	      (entry-point
diff --git a/collects/redex/HISTORY b/collects/redex/HISTORY
index 1a51f5bcc3..cd8b96dea2 100644
--- a/collects/redex/HISTORY
+++ b/collects/redex/HISTORY
@@ -1,3 +1,10 @@
+  - added more coloring arguments to traces: #:scheme-colors? 
+  #:default-arrow-highlight-color, and #:default-arrow-color
+
+  - added the #:layout argument to traces 
+
+  - added term-node-set-position!
+
   - Added tracing to metafunctions (see current-traced-metafunctions)
 
   - added caching-enabled? parameter (changed how set-cache-size! 
diff --git a/collects/redex/gui.ss b/collects/redex/gui.ss
index 7dfb5151c9..873595fc01 100644
--- a/collects/redex/gui.ss
+++ b/collects/redex/gui.ss
@@ -33,8 +33,21 @@
                #:pred (or/c (any/c . -> . any)
                             (any/c term-node? . -> . any))
                #:pp pp-contract
-               #:colors (listof any/c))
+               #:colors (listof (list/c string? string?))
+               #:scheme-colors? boolean?
+               #:layout (-> any/c any/c))
               any)]
+ [traces/ps (->* (reduction-relation?
+                  any/c
+                  (or/c path-string? path?))
+                 (#:multiple?
+                  boolean?
+                  #:pred (or/c (any/c . -> . any)
+                               (any/c term-node? . -> . any))
+                  #:pp pp-contract
+                  #:colors (listof any/c)
+                  #:layout (-> any/c any/c))
+                 any)]
  
  [term-node? (-> any/c boolean?)]
  [term-node-parents (-> term-node? (listof term-node?))]
@@ -45,6 +58,11 @@
                            (or/c string? (is-a?/c color%) false/c)
                            void?)]
  [term-node-expr (-> term-node? any)]
+ [term-node-set-position! (-> term-node? real? real? void?)]
+ [term-node-x (-> term-node? real?)]
+ [term-node-y (-> term-node? real?)]
+ [term-node-width (-> term-node? real?)]
+ [term-node-height (-> term-node? real?)]
  
  [stepper
   (->* (reduction-relation?
@@ -55,10 +73,16 @@
   (->* (reduction-relation?
         (cons/c any/c (listof any/c)))
        (pp-contract)
-       void?)])
-
-
-(provide reduction-steps-cutoff initial-font-size initial-char-width
-         dark-pen-color light-pen-color dark-brush-color light-brush-color
-         dark-text-color light-text-color
+       void?)]
+ 
+ [dark-pen-color (parameter/c (or/c string? (is-a?/c color%)))]
+ [light-pen-color (parameter/c (or/c string? (is-a?/c color%)))]
+ [dark-brush-color (parameter/c (or/c string? (is-a?/c color%)))]
+ [light-brush-color (parameter/c (or/c string? (is-a?/c color%)))]
+ [dark-text-color (parameter/c (or/c string? (is-a?/c color%)))]
+ [light-text-color (parameter/c (or/c string? (is-a?/c color%)))]
+ [initial-font-size (parameter/c number?)]
+ [initial-char-width (parameter/c number?)])
+         
+(provide reduction-steps-cutoff
          default-pretty-printer)
\ No newline at end of file
diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss
index c077fcf151..dbd0e873dc 100644
--- a/collects/redex/private/reduction-semantics.ss
+++ b/collects/redex/private/reduction-semantics.ss
@@ -753,22 +753,32 @@
                                           acc)))]))
                other-matches)))))
    (rewrite-proc-name child-make-proc)
-   (subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from)))
+   (subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from)
+   (rewrite-proc-id child-make-proc)))
 
 (define relation-coverage (make-parameter #f))
 
-(define-struct covered-case (name apps) #:inspector (make-inspector))
+(define (cover-case id name cov)
+  (hash-update! (coverage-unwrap cov) id 
+                (λ (c) (cons (car c) (add1 (cdr c))))
+                (λ () (raise-user-error 
+                       'relation-coverage
+                       "coverage structure not initilized for this relation"))))
 
-(define (apply-case c)
-  (struct-copy covered-case c [apps (add1 (covered-case-apps c))]))
+(define (covered-cases cov)
+  (hash-map (coverage-unwrap cov) (λ (k v) v)))
 
-(define (cover-case id name relation-coverage)
-  (hash-update! relation-coverage id apply-case (make-covered-case name 0)))
+(define-struct coverage (unwrap))
 
-(define (covered-cases relation-coverage)
-  (hash-map relation-coverage (λ (k v) v)))
+(define (fresh-coverage relation)
+  (let ([h (make-hasheq)])
+    (for-each 
+     (λ (rwp) 
+       (hash-set! h (rewrite-proc-id rwp) (cons (or (rewrite-proc-name rwp) "unnamed") 0)))
+     (reduction-relation-make-procs relation))
+    (make-coverage h)))
 
-(define fresh-coverage make-hasheq)
+;(define fresh-coverage (compose make-coverage make-hasheq))
 
 (define (do-leaf-match name pat w/extras proc)
   (let ([case-id (gensym)])
@@ -788,7 +798,8 @@
                          other-matches)
                  other-matches)))))
      name
-     w/extras)))
+     w/extras
+     case-id)))
 
 (define-syntax (test-match stx)
   (syntax-case stx ()
@@ -1835,5 +1846,5 @@
 
 (provide relation-coverage
          covered-cases
-         fresh-coverage
-         (struct-out covered-case))
\ No newline at end of file
+         (rename-out [fresh-coverage make-coverage])
+         coverage?)
\ No newline at end of file
diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss
index a46e922206..08393a1a2d 100644
--- a/collects/redex/private/rg-test.ss
+++ b/collects/redex/private/rg-test.ss
@@ -504,62 +504,62 @@
       (get-output-string p)
       (close-output-port p))))
 
-;; check
+;; redex-check
 (let ()
   (define-language lang
     (d 5)
     (e e 4)
     (n number))
-  (test (current-output (λ () (check lang d #f))) 
+  (test (current-output (λ () (redex-check lang d #f))) 
         "counterexample found after 1 attempts:\n5\n")
-  (test (check lang d #t) #t)
-  (test (check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2) #t)
-  (test (check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2) #t)
-  (test (current-output (λ () (check lang (d e) #f)))
+  (test (redex-check lang d #t) #t)
+  (test (redex-check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2) #t)
+  (test (redex-check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2) #t)
+  (test (current-output (λ () (redex-check lang (d e) #f)))
         "counterexample found after 1 attempts:\n(5 4)\n")
-  (test (current-output (λ () (check lang d (error 'pred-raised))))
+  (test (current-output (λ () (redex-check lang d (error 'pred-raised))))
         "counterexample found after 1 attempts:\n5\n")
   (test (parameterize ([check-randomness (make-random 0 0)])
-          (check lang n (eq? 42 (term n)) 
-                 #:attempts 1
-                 #:source (reduction-relation lang (--> 42 x))))
+          (redex-check lang n (eq? 42 (term n)) 
+                       #:attempts 1
+                       #:source (reduction-relation lang (--> 42 x))))
         #t)
   (test (current-output
          (λ ()
            (parameterize ([check-randomness (make-random 0 0)])
-             (check lang n (eq? 42 (term n)) 
-                    #:attempts 1
-                    #:source (reduction-relation lang (--> 0 x z))))))
+             (redex-check lang n (eq? 42 (term n)) 
+                          #:attempts 1
+                          #:source (reduction-relation lang (--> 0 x z))))))
         "counterexample found (z) after 1 attempts:\n0\n")
   (test (current-output
          (λ ()
            (parameterize ([check-randomness (make-random 1)])
-             (check lang d (eq? 42 (term n)) 
-                    #:attempts 1
-                    #:source (reduction-relation lang (--> 0 x z))))))
+             (redex-check lang d (eq? 42 (term n)) 
+                          #:attempts 1
+                          #:source (reduction-relation lang (--> 0 x z))))))
         "counterexample found after 1 attempts:\n5\n")
   (test (let ([r (reduction-relation lang (--> 0 x z))])
-          (check lang n (number? (term n)) 
-                 #:attempts 10
-                 #:source r))
+          (redex-check lang n (number? (term n)) 
+                       #:attempts 10
+                       #:source r))
         #t)
   (let ()
     (define-metafunction lang
       [(mf 0) 0]
       [(mf 42) 0])
     (test (parameterize ([check-randomness (make-random 0 1)])
-            (check lang (n) (eq? 42 (term n)) 
-                   #:attempts 1
-                   #:source mf))
+            (redex-check lang (n) (eq? 42 (term n)) 
+                         #:attempts 1
+                         #:source mf))
           #t))
   (let ()
     (define-language L)
     (test (with-handlers ([exn:fail? exn-message])
-            (check lang any #t #:source (reduction-relation L (--> 1 1))))
+            (redex-check lang any #t #:source (reduction-relation L (--> 1 1))))
           #rx"language for secondary source"))
   (let ()
     (test (with-handlers ([exn:fail? exn-message])
-            (check lang n #t #:source (reduction-relation lang (--> x 1))))
+            (redex-check lang n #t #:source (reduction-relation lang (--> x 1))))
           #rx"x does not match n"))
   
   (let ([stx-err (λ (stx)
@@ -570,15 +570,15 @@
       (eval '(require "../reduction-semantics.ss"
                       "rg.ss"))
       (eval '(define-language empty))
-      (test (stx-err '(check empty any #t #:typo 3))
-            #rx"check: bad keyword syntax")
-      (test (stx-err '(check empty any #t #:attempts 3 #:attempts 4))
+      (test (stx-err '(redex-check empty any #t #:typo 3))
+            #rx"redex-check: bad keyword syntax")
+      (test (stx-err '(redex-check empty any #t #:attempts 3 #:attempts 4))
             #rx"bad keyword syntax")
-      (test (stx-err '(check empty any #t #:attempts))
+      (test (stx-err '(redex-check empty any #t #:attempts))
             #rx"bad keyword syntax")
-      (test (stx-err '(check empty any #t #:attempts 3 4))
+      (test (stx-err '(redex-check empty any #t #:attempts 3 4))
             #rx"bad keyword syntax")
-      (test (stx-err '(check empty any #t #:source #:attempts))
+      (test (stx-err '(redex-check empty any #t #:source #:attempts))
             #rx"bad keyword syntax"))))
 
 ;; check-metafunction-contract
diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss
index 6174f0ac82..3b700c2424 100644
--- a/collects/redex/private/rg.ss
+++ b/collects/redex/private/rg.ss
@@ -655,11 +655,12 @@ To do a better job of not generating programs with free variables,
 
 (define check-randomness (make-parameter random))
 
-(define-syntax (check stx)
+(define-syntax (redex-check stx)
   (syntax-case stx ()
     [(_ lang pat property . kw-args)
      (let-values ([(names names/ellipses) 
-                   (extract-names (language-id-nts #'lang 'check) 'check #t #'pat)]
+                   (extract-names (language-id-nts #'lang 'redex-check)
+                                  'redex-check #t #'pat)]
                   [(attempts-stx source-stx)
                    (let loop ([args (syntax kw-args)]
                               [attempts #f]
@@ -678,9 +679,9 @@ To do a better job of not generating programs with free variables,
                      [attempts (or attempts-stx #'default-check-attempts)])
          (quasisyntax/loc stx
            (let ([att attempts])
-             (assert-nat 'check att)
+             (assert-nat 'redex-check att)
              (or (check-property 
-                  (cons (list #,(term-generator #'lang #'pat #'random-decisions 'check) #f)
+                  (cons (list #,(term-generator #'lang #'pat #'random-decisions 'redex-check) #f)
                         (let ([lang-gen (generate lang (random-decisions lang))])
                           #,(if (not source-stx)
                                 #'null
@@ -694,16 +695,16 @@ To do a better job of not generating programs with free variables,
                                                 [else
                                                  #`(let ([r #,source-stx])
                                                      (unless (reduction-relation? r)
-                                                       (raise-type-error 'check "reduction-relation" r))
+                                                       (raise-type-error 'redex-check "reduction-relation" r))
                                                      (values
                                                       (map rewrite-proc-lhs (reduction-relation-make-procs r))
                                                       (reduction-relation-srcs r)
                                                       (reduction-relation-lang r)))])])
                                     (unless (eq? src-lang lang)
-                                      (error 'check "language for secondary source must match primary pattern's language"))
+                                      (error 'redex-check "language for secondary source must match primary pattern's language"))
                                     (zip (map lang-gen pats) srcs)))))
                   #,(and source-stx #'(test-match lang pat))
-                  (λ (generated) (error 'check "~s does not match ~s" generated 'pat))
+                  (λ (generated) (error 'redex-check "~s does not match ~s" generated 'pat))
                   (λ (_ bindings)
                     (term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
                               property))
@@ -842,7 +843,7 @@ To do a better job of not generating programs with free variables,
 (define generation-decisions (make-parameter random-decisions))
 
 (provide pick-from-list pick-var min-prods decisions^ pick-sequence-length
-         is-nt? pick-char random-string pick-string check nt-by-name
+         is-nt? pick-char random-string pick-string redex-check nt-by-name
          pick-nt unique-chars pick-any sexp generate-term parse-pattern
          class-reassignments reassign-classes unparse-pattern
          (struct-out ellipsis) (struct-out mismatch) (struct-out class)
diff --git a/collects/redex/private/struct.ss b/collects/redex/private/struct.ss
index 27cba96f84..f0c4e9d9f1 100644
--- a/collects/redex/private/struct.ss
+++ b/collects/redex/private/struct.ss
@@ -9,7 +9,7 @@
          build-reduction-relation
          reduction-relation?
          empty-reduction-relation
-         make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs
+         make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs rewrite-proc-id
          (struct-out rule-pict))
 
 (define-struct rule-pict (arrow lhs rhs label side-conditions fresh-vars pattern-binds))
@@ -20,14 +20,15 @@
 ;;   we want to avoid doing it multiple times, so it is cached in a reduction-relation struct
 
 
-(define-values (make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs)
+(define-values (make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs rewrite-proc-id)
   (let ()
     (define-values (type constructor predicate accessor mutator) 
-      (make-struct-type 'rewrite-proc #f 3 0 #f '() #f 0))
+      (make-struct-type 'rewrite-proc #f 4 0 #f '() #f 0))
     (values constructor 
             predicate 
             (make-struct-field-accessor accessor 1 'name)
-            (make-struct-field-accessor accessor 2 'lhs))))
+            (make-struct-field-accessor accessor 2 'lhs)
+            (make-struct-field-accessor accessor 3 'id))))
 
 ;; lang : compiled-language
 ;; make-procs = (listof (compiled-lang -> proc))
diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss
index af8919fc49..78aae31d07 100644
--- a/collects/redex/private/tl-test.ss
+++ b/collects/redex/private/tl-test.ss
@@ -1,8 +1,5 @@
 (module tl-test mzscheme
   (require "../reduction-semantics.ss"
-           (only "reduction-semantics.ss" 
-                 relation-coverage fresh-coverage covered-cases
-                 make-covered-case covered-case-name)
            "test-util.ss"
            (only "matcher.ss" make-bindings make-bind)
            scheme/match
@@ -1226,32 +1223,30 @@
             [else #f])
           #t))
   
-  (let ([R (reduction-relation
-            empty-language
-            (--> number (q ,(add1 (term number)))
-                 (side-condition (odd? (term number)))
-                 side-condition)
-            (--> 1 4
-                 one)
-            (==> 2 t
-                 shortcut)
-            with
-            [(--> (q a) b)
-             (==> a b)])]
-        [c (fresh-coverage)])
+  (let* ([R (reduction-relation
+             empty-language
+             (--> number (q ,(add1 (term number)))
+                  (side-condition (odd? (term number)))
+                  side-condition)
+             (--> 1 4)
+             (==> 2 t
+                  shortcut)
+             with
+             [(--> (q a) b)
+              (==> a b)])]
+         [c (make-coverage R)]
+         [< (λ (c d) (string<? (car c) (car d)))])
     (parameterize ([relation-coverage c])
       (apply-reduction-relation R 4)
-      (test (covered-cases c) null)
+      (test (sort (covered-cases c) <)
+            '(("shortcut" . 0) ("side-condition" . 0) ("unnamed" . 0)))
       
       (apply-reduction-relation R 3)
-      (test (covered-cases c)
-            (list (make-covered-case "side-condition" 1)))
+      (test (sort (covered-cases c) <)
+            '(("shortcut" . 0) ("side-condition" . 1) ("unnamed" . 0)))
       
       (apply-reduction-relation* R 1)
-      (test (sort (covered-cases c)
-                  (λ (c d) (string<? (covered-case-name c) (covered-case-name d))))
-            (list (make-covered-case "one" 1)
-                  (make-covered-case "shortcut" 1)
-                  (make-covered-case "side-condition" 2)))))
+      (test (sort (covered-cases c) <)
+            '(("shortcut" . 1) ("side-condition" . 2) ("unnamed" . 1)))))
   
   (print-tests-passed 'tl-test.ss))
diff --git a/collects/redex/private/traces.ss b/collects/redex/private/traces.ss
index 5efb8c074e..ebddb6617f 100644
--- a/collects/redex/private/traces.ss
+++ b/collects/redex/private/traces.ss
@@ -30,15 +30,87 @@
 (define (term-node-expr term-node) (send (term-node-snip term-node) get-expr))
 (define (term-node-labels term-node) (send (term-node-snip term-node) get-one-step-labels))
 (define (term-node-set-color! term-node r?)
-  (let loop ([snip (term-node-snip term-node)])
-    (parameterize ([current-eventspace (send snip get-my-eventspace)])
-      (queue-callback
-       (λ ()
-         (send (term-node-snip term-node) set-bad r?))))))
+  (snip/eventspace
+   (λ ()
+     (send (term-node-snip term-node) set-bad r?))))
 
 (define (term-node-set-red! term-node r?)
   (term-node-set-color! term-node (and r? "pink")))
 
+(define (term-node-set-position! term-node x y)
+  (snip/eventspace/ed 
+   term-node
+   (λ (ed)
+     (when ed
+       (send ed move-to (term-node-snip term-node) x y)))))
+
+(define (term-node-width term-node)
+  (snip/eventspace/ed 
+   term-node
+   (λ (ed)
+     (let ([lb (box 0)]
+           [rb (box 0)]
+           [snip (term-node-snip term-node)])
+       (if (and (send ed get-snip-location snip lb #f #f)
+                (send ed get-snip-location snip rb #f #t))
+           (- (unbox rb) (unbox lb))
+           0)))))
+
+(define (term-node-height term-node)
+  (snip/eventspace/ed 
+   term-node
+   (λ (ed)
+     (let ([tb (box 0)]
+           [bb (box 0)]
+           [snip (term-node-snip term-node)])
+       (if (and (send ed get-snip-location snip #f tb #f)
+                (send ed get-snip-location snip #f bb #t))
+           (- (unbox bb) (unbox tb))
+           0)))))
+
+(define (term-node-x term-node)
+  (snip/eventspace/ed 
+   term-node
+   (λ (ed)
+     (let ([xb (box 0)]
+           [snip (term-node-snip term-node)])
+       (if (send ed get-snip-location snip xb #f #f)
+           (unbox xb)
+           0)))))
+
+(define (term-node-y term-node)
+  (snip/eventspace/ed 
+   term-node
+   (λ (ed)
+     (let ([yb (box 0)]
+           [snip (term-node-snip term-node)])
+       (if (send ed get-snip-location snip yb #f #f)
+           (unbox yb)
+           0)))))
+
+(define (snip/eventspace/ed term-node f)
+  (snip/eventspace 
+   term-node
+   (λ ()
+     (let* ([snip (term-node-snip term-node)]
+            [admin (send snip get-admin)])
+       (f (and admin (send admin get-editor)))))))
+
+  
+(define (snip/eventspace term-node thunk)
+  (let* ([snip (term-node-snip term-node)]
+         [eventspace (send snip get-my-eventspace)])
+    (cond
+      [(eq? (current-eventspace) eventspace)
+       (thunk)]
+      [else
+       (let ([c (make-channel)])
+         (parameterize ([current-eventspace eventspace])
+           (queue-callback
+            (λ ()
+              (channel-put c (thunk)))))
+         (channel-get c))])))
+
 (define initial-font-size
   (make-parameter
    (send (send (send (editor:get-standard-style-list) 
@@ -51,7 +123,37 @@
 (define x-spacing 15)
 (define y-spacing 15)
 
-(define (traces reductions pre-exprs #:multiple? [multiple? #f] #:pred [pred (λ (x) #t)] #:pp [pp default-pretty-printer] #:colors [colors '()])
+(define (traces/ps reductions pre-exprs filename
+                   #:multiple? [multiple? #f] 
+                   #:pred [pred (λ (x) #t)] 
+                   #:pp [pp default-pretty-printer] 
+                   #:scheme-colors? [scheme-colors? #t]
+                   #:colors [colors '()]
+                   #:layout [layout void])
+  (let-values ([(graph-pb frame)
+                (traces reductions pre-exprs
+                        #:no-show-frame? #t
+                        #:multiple? multiple? 
+                        #:pred pred
+                        #:pp pp
+                        #:scheme-colors? scheme-colors?
+                        #:colors colors
+                        #:layout layout)])
+    (let ([ps-setup (make-object ps-setup%)])
+      (send ps-setup copy-from (current-ps-setup))
+      (send ps-setup set-file filename)
+      (send ps-setup set-mode 'file)
+      (parameterize ([current-ps-setup ps-setup])
+        (send graph-pb print #f #f 'postscript #f #f #t)))))
+
+(define (traces reductions pre-exprs 
+                #:multiple? [multiple? #f] 
+                #:pred [pred (λ (x) #t)] 
+                #:pp [pp default-pretty-printer] 
+                #:colors [colors '()]
+                #:scheme-colors? [scheme-colors? #t]
+                #:layout [layout void]
+                #:no-show-frame? [no-show-frame? #f])
   (define exprs (if multiple? pre-exprs (list pre-exprs)))
   (define main-eventspace (current-eventspace))
   (define saved-parameterization (current-parameterization))
@@ -146,14 +248,18 @@
         (semaphore-wait s)
         ans)))
   
+  (define default-colors (list (dark-pen-color) (light-pen-color) 
+                               (dark-text-color) (light-text-color)
+                               (dark-brush-color) (light-brush-color)))
+  
   ;; only changed on the reduction thread
   ;; frontier : (listof (is-a?/c graph-editor-snip%))
   (define frontier 
     (filter
      (λ (x) x)
-     (map (lambda (expr) (build-snip snip-cache #f expr pred pp 
-                                     (dark-pen-color) (light-pen-color)
-                                     (dark-text-color) (light-text-color) #f))
+     (map (lambda (expr) (apply build-snip
+                                snip-cache #f expr pred pp #f scheme-colors?
+                                default-colors))
           exprs)))
   
   ;; set-font-size : number -> void
@@ -172,38 +278,29 @@
             (send snip shrink-down))
           (loop (send snip next))))))
   
-  ;; color-spec-list->color-scheme : (list (union string? #f)^4) -> (list string?^4)
-  ;; converts a list of user-specified colors (including false) into a list of color strings, filling in
-  ;; falses with the default colors
-  (define (color-spec-list->color-scheme l)
-    (map (λ (c d) (or c d))
-         l 
-         (list (dark-pen-color) (light-pen-color) (dark-text-color) (light-text-color))))
-  
+  ;; fill-out : (listof X) (listof X) -> (listof X)
+  ;; produces a list whose length matches defaults but
+  (define (fill-out l defaults)
+    (let loop ([l l]
+               [default defaults])
+      (cond
+        [(null? l) defaults]
+        [else 
+         (cons (car l) (loop (cdr l) (cdr defaults)))])))
   
   (define name->color-ht 
     (let ((ht (make-hash)))
       (for-each 
        (λ (c)
-         (hash-set! ht (car c) 
-                    (color-spec-list->color-scheme
-                     (match (cdr c)
-                       [`(,color)
-                        (list color color (dark-text-color) (light-text-color))]
-                       [`(,dark-arrow-color ,light-arrow-color)
-                        (list dark-arrow-color light-arrow-color (dark-text-color) (light-text-color))]
-                       [`(,dark-arrow-color ,light-arrow-color ,text-color) 
-                        (list dark-arrow-color light-arrow-color text-color text-color)]
-                       [`(,_ ,_ ,_ ,_)
-                        (cdr c)]))))
+         (hash-set! ht (car c) (fill-out (cdr c) default-colors)))
        colors)
       ht))
   
-  ;; red->colors : string -> (values string string string string)
+  ;; red->colors : string -> (values string string string string string string)
   (define (red->colors reduction-name)
     (apply values (hash-ref name->color-ht
                             reduction-name 
-                            (λ () (list (dark-pen-color) (light-pen-color) (dark-text-color) (light-text-color))))))
+                            default-colors)))
   
   ;; reduce-frontier : -> void
   ;; =reduction thread=
@@ -225,11 +322,13 @@
                            (let-values ([(name sexp) (apply values red+sexp)])
                              (call-on-eventspace-main-thread
                               (λ ()
-                                (let-values ([(dark-arrow-color light-arrow-color dark-label-color light-label-color) 
+                                (let-values ([(dark-arrow-color light-arrow-color dark-label-color light-label-color
+                                                                dark-pen-color
+                                                                light-pen-color) 
                                               (red->colors name)])
-                                  (build-snip snip-cache snip sexp pred pp 
+                                  (build-snip snip-cache snip sexp pred pp name scheme-colors? 
                                               light-arrow-color dark-arrow-color dark-label-color light-label-color
-                                              name))))))
+                                              dark-pen-color light-pen-color))))))
                          (apply-reduction-relation/tag-with-names reductions (send snip get-expr))))]
                   [new-y 
                    (call-on-eventspace-main-thread
@@ -239,6 +338,7 @@
                         (set! col (+ x-spacing (find-rightmost-x graph-pb))))
                       (begin0
                         (insert-into col y graph-pb new-snips)
+                        (layout (hash-map snip-cache (lambda (x y) (send y get-term-node))))
                         (send graph-pb end-edit-sequence)
                         (send status-message set-label
                               (string-append (term-count (count-snips)) "...")))))])
@@ -369,9 +469,19 @@
               null)))
   (out-of-dot-state) ;; make sure the state is initialized right
   (insert-into init-rightmost-x 0 graph-pb frontier)
+  (layout (map (lambda (y) (send y get-term-node)) frontier))
   (set-font-size (initial-font-size))
-  (reduce-button-callback)
-  (send f show #t))
+  (cond
+    [no-show-frame?
+     (let ([s (make-semaphore)]) 
+       (thread (λ () 
+                 (do-some-reductions)
+                 (semaphore-post s)))
+       (yield s))
+     (values graph-pb f)]
+    [else
+     (reduce-button-callback)
+     (send f show #t)]))
 
 (define red-sem-frame%
   (class (frame:standard-menus-mixin (frame:basic-mixin frame%))
@@ -509,20 +619,22 @@
 ;;              sexp
 ;;              sexp -> boolean
 ;;              (any port number -> void)
-;;              color
 ;;              (union #f string)
+;;              color^6
 ;;           -> (union #f (is-a?/c graph-editor-snip%))
 ;; returns #f if a snip corresponding to the expr has already been created.
 ;; also adds in the links to the parent snip
 ;; =eventspace main thread=
-(define (build-snip cache parent-snip expr pred pp light-arrow-color dark-arrow-color dark-label-color light-label-color name)
+(define (build-snip cache parent-snip expr pred pp name scheme-colors?
+                    light-arrow-color dark-arrow-color dark-label-color light-label-color
+                    dark-brush-color light-brush-color)
   (let-values ([(snip new?)
                 (let/ec k
                   (values (hash-ref
                            cache
                            expr
                            (lambda ()
-                             (let ([new-snip (make-snip parent-snip expr pred pp)])
+                             (let ([new-snip (make-snip parent-snip expr pred pp scheme-colors?)])
                                (hash-set! cache expr new-snip)
                                (k new-snip #t))))
                           #f))])
@@ -532,10 +644,14 @@
       (add-links/text-colors parent-snip snip
                              (send the-pen-list find-or-create-pen dark-arrow-color 0 'solid)
                              (send the-pen-list find-or-create-pen light-arrow-color 0 'solid)
-                             (send the-brush-list find-or-create-brush (dark-brush-color) 'solid)
-                             (send the-brush-list find-or-create-brush (light-brush-color) 'solid)
-                             (make-object color% dark-label-color)
-                             (make-object color% light-label-color)
+                             (send the-brush-list find-or-create-brush dark-brush-color 'solid)
+                             (send the-brush-list find-or-create-brush light-brush-color 'solid)
+                             (if (is-a? dark-label-color color%)
+                                 dark-label-color
+                                 (make-object color% dark-label-color))
+                             (if (is-a? light-label-color color%)
+                                 light-label-color
+                                 (make-object color% light-label-color))
                              0 0
                              name)
       (update-badness pred parent-snip (send parent-snip get-expr)))
@@ -563,7 +679,7 @@
 ;;          -> (is-a?/c graph-editor-snip%)
 ;; unconditionally creates a new graph-editor-snip
 ;; =eventspace main thread=
-(define (make-snip parent-snip expr pred pp)
+(define (make-snip parent-snip expr pred pp scheme-colors?)
   (let* ([text (new program-text%)]
          [es (instantiate graph-editor-snip% ()
                (char-width (initial-char-width))
@@ -573,6 +689,7 @@
                (expr expr))])
     (send text set-autowrap-bitmap #f)
     (send text freeze-colorer)
+    (send text stop-colorer (not scheme-colors?))
     (send es format-expr)
     es))
 
@@ -605,12 +722,18 @@
        (unbox bt))))
 
 (provide traces
+         traces/ps
          term-node?
          term-node-parents
          term-node-children
          term-node-labels 
          term-node-set-red!
          term-node-set-color!
+         term-node-set-position!
+         term-node-x
+         term-node-y
+         term-node-width
+         term-node-height
          term-node-expr)
 
 (provide reduction-steps-cutoff initial-font-size
diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl
index 0335ffc8cd..34c0415cd6 100644
--- a/collects/redex/redex.scrbl
+++ b/collects/redex/redex.scrbl
@@ -47,9 +47,12 @@
      #'((tech "term") args ...)]
     [x (identifier? #'x) #'(tech "term")]))
 
+@(define redex-eval (make-base-eval))
+@(interaction-eval #:eval redex-eval (require redex/reduction-semantics))
+
 @title{@bold{Redex}: Debugging Operational Semantics}
 
-@author["Robert Bruce Findler"]
+@author["Robert Bruce Findler" "Casey Klein"]
 
 PLT Redex consists of a domain-specific language for specifying
 reduction semantics, plus a suite of tools for working with the
@@ -982,6 +985,128 @@ counters so that next time this function is called, it
 prints the test results for the next round of tests.
 }
 
+@defproc[(make-coverage [r reduction-relation?]) coverage?]{
+Constructs a structure to contain the per-case test coverage of
+the relation @scheme[r]. Use with @scheme[relation-coverage]
+and @scheme[covered-cases].
+}
+
+@defproc[(coverage? [v any/c]) boolean?]{
+Returns @scheme[#t] for a value produced by @scheme[make-coverage]
+and @scheme[#f] for any other.}
+
+@defparam[relation-coverage c (or/c false/c coverage?)]{
+When @scheme[c] is a @scheme[coverage] structure, rather than 
+@scheme[#f] (the default), procedures such as
+@scheme[apply-reduction-relation], @scheme[traces], etc. count 
+the number applications of each case of the
+@scheme[reduction-relation], storing the results in @scheme[c].
+}
+
+@defproc[(covered-cases 
+          [c coverage?])
+         (listof (cons/c string? natural-number/c))]{
+Extracts the coverage information recorded in @scheme[c], producing
+an association list mapping names to application counts.}
+
+@examples[
+#:eval redex-eval
+       (define-language empty-lang)
+       
+       (define equals
+         (reduction-relation 
+          empty-lang
+          (--> (+) 0 "zero")
+          (--> (+ number) number)
+          (--> (+ number_1 number_2 number ...)
+               (+ ,(+ (term number_1) (term number_2))
+                  number ...)
+               "add")))
+       (let ([coverage (make-coverage equals)])
+         (parameterize ([relation-coverage coverage])
+           (apply-reduction-relation* equals (term (+ 1 2 3)))
+           (covered-cases coverage)))]
+
+@defform*[[(generate-term language #, @|ttpattern| size-exp)
+           (generate-term language #, @|ttpattern| size-exp #:attempt attempt-num-expr)]
+          #:contracts ([size-expr natural-number/c]
+                       [attempt-num-expr natural-number/c])]{
+Generates a random term matching @scheme[pattern] (in the given language).
+
+The argument @scheme[size-expr] bounds the height of the generated term
+(measured as the height of the derivation tree used to produce
+the term). 
+         
+The optional keyword argument @scheme[attempt-num-expr] 
+(default @scheme[1]) provides coarse grained control over the random
+decisions made during generation (e.g., the expected length of 
+@pattech[pattern-sequence]s increases with @scheme[attempt-num-expr]).}
+
+@defform/subs[(redex-check language #, @|ttpattern| property-expr kw-arg ...)
+              ([kw-arg (code:line #:attempts attempts-expr)
+                       (code:line #:source metafunction)
+                       (code:line #:source relation-expr)])
+              #:contracts ([property-expr any/c]
+                           [attempts-expr natural-number/c]
+                           [relation-expr reduction-relation?])]{
+Searches for a counterexample to @scheme[property-expr], interpreted
+as a predicate universally quantified over its free
+@pattech[term]-variables. @scheme[redex-check] chooses substitutions for 
+these free @pattech[term]-variables by generating random terms matching
+@scheme[pattern] and extracting the sub-terms bound by the
+@pattech[names] and non-terminals in @scheme[pattern].
+
+@examples[
+#:eval redex-eval
+       (define-language empty-lang)
+       
+       (random-seed 0)
+
+       (redex-check 
+        empty-lang
+        ((number_1 ...)
+         (number_2 ...))
+        (equal? (reverse (append (term (number_1 ...))
+                                 (term (number_2 ...))))
+                (append (reverse (term (number_1 ...)))
+                        (reverse (term (number_2 ...))))))
+
+       (redex-check 
+        empty-lang
+        ((number_1 ...)
+         (number_2 ...))
+        (equal? (reverse (append (term (number_1 ...))
+                                 (term (number_2 ...))))
+                (append (reverse (term (number_2 ...)))
+                        (reverse (term (number_1 ...)))))
+        #:attempts 200)]
+
+@scheme[redex-check] generates at most @scheme[attempts-expr] (default @scheme[100])
+random terms in its search. The size and complexity of terms it generates
+gradually increases with each failed attempt.
+
+When the optional @scheme[#:source] argument is present, @scheme[redex-check] 
+generates @math{10%} of its terms by randomly choosing a pattern from the
+left-hand sides the definition of the supplied metafunction or relation.
+@scheme[redex-check] raises an exception if a term generated from an alternate
+pattern does not match the @scheme[pattern].}
+
+@defproc[(check-reduction-relation 
+          [relation reduction-relation?]
+          [property (-> any/c any/c)]
+          [#:attempts attempts natural-number/c 100])
+         (or/c true/c void?)]{
+Tests a @scheme[relation] as follows: for each case of @scheme[relation],
+@scheme[check-reduction-relation] generates @scheme[attempts] random
+terms that match that case's left-hand side and applies @scheme[property] 
+to each random term.}
+
+@defform*[[(check-metafunction metafunction property)
+           (check-metafunction metafunction property #:attempts attempts)]
+          #:contracts ([property (-> any/c any/c)]
+                       [attempts natural-number/c])]{
+Like @scheme[check-reduction-relation] but for metafunctions.}
+
 @deftech{Debugging PLT Redex Programs}
 
 It is easy to write grammars and reduction rules that are
@@ -1017,13 +1142,21 @@ exploring reduction sequences.
                  [expr (or/c any/c (listof any/c))]
                  [#:multiple? multiple? boolean? #f]
                  [#:pred pred
-                         (or/c (sexp -> any) (sexp term-node? any))
+                         (or/c (-> sexp any)
+                               (-> sexp term-node? any))
                          (lambda (x) #t)]
                  [#:pp pp
                        (or/c (any -> string)
                              (any output-port number (is-a?/c text%) -> void))
                        default-pretty-printer]
-                 [#:colors colors (listof (list string string)) '()])
+                 [#:colors colors 
+                  (listof 
+                   (cons/c string 
+                           (and/c (listof (or/c string? (is-a?/c color%)))
+                                  (lambda (x) (member (length x) '(2 3 4 6))))))]
+
+	         [#:scheme-colors? scheme-colors? boolean?]
+                 [#:layout layout (-> (listof term-node?) void)])
          void?]{
 
 This function opens a new window and inserts each expression
@@ -1063,14 +1196,56 @@ final argument is the text where the port is connected --
 characters written to the port go to the end of the editor.
 
 The @scheme[colors] argument, if provided, specifies a list of
-reduction-name/color-string pairs. The traces gui will color
-arrows drawn because of the given reduction name with the
-given color instead of using the default color.
+reduction-name/color-list pairs. The traces gui will color arrows
+drawn because of the given reduction name with the given color instead
+of using the default color.
+
+The @scheme[cdr] of each of the elements of @scheme[colors] is a list
+of colors, organized in pairs. The first two colors cover the colors
+of the line and the border around the arrow head, the first when the
+mouse is over a graph node that is connected to that arrow, and the
+second for when the mouse is not over that arrow. Similarly, the next
+colors are for the text drawn on the arrow and the last two are for
+the color that fills the arrow head.  If fewer than six colors are
+specified, the colors specified colors are used and then defaults are
+filled in for the remaining colors.
+
+
+
+The @scheme[scheme-colors?] argument, if @scheme[#t] causes
+@scheme[traces] to color the contents of each of the windows according
+to DrScheme's Scheme mode color Scheme. If it is @scheme[#f],
+@scheme[traces] just uses black for the color scheme.
+
+The @scheme[layout] argument is called (with all of the terms) each
+time a new term is inserted into the window. See also
+@scheme[term-node-set-position!].
 
 You can save the contents of the window as a postscript file
 from the menus.
 }
 
+@defproc[(traces/ps [reductions reduction-relation?] 
+                    [expr (or/c any/c (listof any/c))]
+                    [file (or/c path-string? path?)]
+                    [#:multiple? multiple? boolean? #f]
+                    [#:pred pred
+                            (or/c (-> sexp any)
+                                  (-> sexp term-node? any))
+                            (lambda (x) #t)]
+                    [#:pp pp
+                          (or/c (any -> string)
+                                (any output-port number (is-a?/c text%) -> void))
+                          default-pretty-printer]
+                    [#:colors colors (listof (list string string)) '()]
+                    [#:layout layout (-> (listof term-node?) void)])
+         void?]{
+
+The arguments behave just like the function @scheme[traces], but
+instead of opening a window to show the reduction graph, it just saves
+the reduction graph to the specified @scheme[file].
+}
+
 @defproc[(stepper [reductions reduction-relation?] 
                   [t any/c] 
                   [pp (or/c (any -> string)
@@ -1146,6 +1321,24 @@ not colored specially.
 Returns the expression in this node.
 }
 
+@defproc[(term-node-set-position! [tn term-node?] [x (and/c real? positive?)] [y (and/c real? positive?)]) void?]{
+
+Sets the position of @scheme[tn] in the graph to (@scheme[x],@scheme[y]). 
+}
+
+@defproc[(term-node-x [tn term-node?]) real]{
+Returns the @tt{x} coordinate of @scheme[tn] in the window.
+}
+@defproc[(term-node-y [tn term-node?]) real]{
+Returns the @tt{y} coordinate of @scheme[tn] in the window.
+}
+@defproc[(term-node-width [tn term-node?]) real]{
+Returns the width of @scheme[tn] in the window.
+}
+@defproc[(term-node-height [tn term-node?]) real?]{
+Returns the height of @scheme[tn] in the window.
+}
+
 @defproc[(term-node? [v any/c]) boolean?]{
 
 Recognizes term nodes.
diff --git a/collects/redex/reduction-semantics.ss b/collects/redex/reduction-semantics.ss
index dfbd96b498..68c4c14a93 100644
--- a/collects/redex/reduction-semantics.ss
+++ b/collects/redex/reduction-semantics.ss
@@ -7,8 +7,6 @@
          "private/rg.ss"
          "private/error.ss")
 
-#;(provide (all-from-out "private/rg.ss"))
-
 (provide exn:fail:redex?) ;; from error.ss
 
 (provide reduction-relation 
@@ -43,6 +41,11 @@
          test-predicate
          test-results)
 
+(provide redex-check
+         generate-term
+         check-metafunction
+         check-metafunction-contract)
+
 (provide/contract
  [current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))]
  [reduction-relation->rule-names (-> reduction-relation? (listof symbol?))]
@@ -61,4 +64,10 @@
                   (-> bindings? symbol? any)
                   (-> bindings? symbol? (-> any) any))]
  [variable-not-in (any/c symbol? . -> . symbol?)]
- [variables-not-in (any/c (listof symbol?) . -> . (listof symbol?))])
+ [variables-not-in (any/c (listof symbol?) . -> . (listof symbol?))]
+ [check-reduction-relation (->* (reduction-relation? (-> any/c any/c))
+                                (#:attempts natural-number/c)
+                                (one-of/c #t (void)))]
+ [relation-coverage (parameter/c (or/c false/c coverage?))]
+ [make-coverage (-> reduction-relation? coverage?)]
+ [covered-cases (-> coverage? (listof (cons/c string? natural-number/c)))])
\ No newline at end of file
diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss
index c487735d3b..70606307e7 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "8jan2009")
+#lang scheme/base (provide stamp) (define stamp "12jan2009")
diff --git a/collects/scheme/path.ss b/collects/scheme/path.ss
index d093181713..f047a1ebf0 100644
--- a/collects/scheme/path.ss
+++ b/collects/scheme/path.ss
@@ -6,7 +6,9 @@
          normalize-path
          filename-extension
          file-name-from-path
-         path-only)
+         path-only
+         some-system-path->string
+         string->some-system-path)
 
 (define (simple-form-path p)
   (unless (path-string? p)
@@ -113,18 +115,19 @@
   (let loop ([path orig-path][rest '()])
     (let-values ([(base name dir?) (split-path path)])
       (when simple?
-        (when (or (and base (not (path? base)))
-                  (not (path? name)))
+        (when (or (and base (not (path-for-some-system? base)))
+                  (not (path-for-some-system? name)))
           (raise-type-error who 
-                            "path in simple form (absolute, complete, and with no same- or up-directory indicators)"
+                            "path (for ay platform) in simple form (absolute, complete, and with no same- or up-directory indicators)"
                             orig-path)))
-      (if (path? base)
+      (if (path-for-some-system? base)
           (loop base (cons name rest))
           (cons name rest)))))
 
 (define (explode-path orig-path)
-  (unless (path-string? orig-path)
-    (raise-type-error 'explode-path "path or string" orig-path))
+  (unless (or (path-string? orig-path)
+              (path-for-some-system? orig-path))
+    (raise-type-error 'explode-path "path (for any platform) or string" orig-path))
   (do-explode-path 'explode-path orig-path #f))
 
 ;; Arguments must be in simple form
@@ -143,20 +146,22 @@
         filename)))
 
 (define (file-name who name)
-  (unless (path-string? name)
-    (raise-type-error who "path or string" name))
+  (unless (or (path-string? name)
+              (path-for-some-system? name))
+    (raise-type-error who "path (for any platform) or string" name))
   (let-values ([(base file dir?) (split-path name)])
-    (and (not dir?) (path? file) file)))
+    (and (not dir?) (path-for-some-system? file) file)))
 
 (define (file-name-from-path name)
   (file-name 'file-name-from-path name))
 
 (define (path-only name)
-  (unless (path-string? name)
-    (raise-type-error 'path-only "path or string" name))
+  (unless (or (path-string? name)
+              (path-for-some-system? name))
+    (raise-type-error 'path-only "path (for any platform) or string" name))
   (let-values ([(base file dir?) (split-path name)])
-    (cond [dir? name]
-          [(path? base) base]
+    (cond [dir? (if (string? name) (string->path name) name)]
+          [(path-for-some-system? base) base]
           [else #f])))
 
 ;; name can be any string; we just look for a dot
@@ -165,3 +170,18 @@
          [name (and name (path->bytes name))])
     (cond [(and name (regexp-match #rx#"[.]([^.]+)$" name)) => cadr]
           [else #f])))
+
+(define (some-system-path->string path)
+  (unless (path-for-some-system? path)
+    (raise-type-error 'some-system-path->string "path (for any platform)" path))
+  (bytes->string/utf-8 (path->bytes path)))
+
+(define (string->some-system-path path kind)
+  (unless (string? path)
+    (raise-type-error 'string->some-system-path "string" path))
+  (unless (or (eq? kind 'unix)
+              (eq? kind 'windows))
+    (raise-type-error 'string->some-system-path "'unix or 'windows" kind))
+  (bytes->path (string->bytes/utf-8 path) kind))
+
+
diff --git a/collects/scheme/private/classidmap.ss b/collects/scheme/private/classidmap.ss
index b88fb8b098..ba0d93e6eb 100644
--- a/collects/scheme/private/classidmap.ss
+++ b/collects/scheme/private/classidmap.ss
@@ -291,7 +291,14 @@
        [else
 	(reverse (cons args accum))])))
 
-  (define-struct private-name (orig-id gen-id))
+  (define-struct private-name (orig-id gen-id)
+    #:property prop:procedure (lambda (self stx)
+                                (if (not (eq? (syntax-local-context) 'expression))
+                                    #`(#%expression #,stx)
+                                    (raise-syntax-error
+                                     #f
+                                     "unbound local member name"
+                                     stx))))
 
   (define (do-localize orig-id validate-local-member-stx)
     (let loop ([id orig-id])
diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss
index abf622217c..1faade5843 100644
--- a/collects/scheme/private/contract.ss
+++ b/collects/scheme/private/contract.ss
@@ -51,7 +51,48 @@ improve method arity mismatch contract violation error messages?
                        #,(syntax-span id))
           #,(format "~s" (syntax->datum id))))
 
-
+(define-for-syntax (make-contracted-transformer contract-id id pos-module-source)
+  (make-set!-transformer
+   (let ([saved-id-table (make-hasheq)])
+     (λ (stx)
+       (if (eq? 'expression (syntax-local-context))
+           ;; In an expression context:
+           (let ([key (syntax-local-lift-context)])
+             ;; Already lifted in this lifting context?
+             (let ([lifted-id
+                    (or (hash-ref saved-id-table key #f)
+                        ;; No: lift the contract creation:
+                        (with-syntax ([contract-id contract-id]
+                                      [id id]
+                                      [neg-blame-id (or (syntax-parameter-value #'current-contract-region)
+                                                        #'(#%variable-reference))]
+                                      [pos-module-source pos-module-source])
+                          (syntax-local-introduce
+                           (syntax-local-lift-expression
+                            #`(-contract contract-id
+                                         id
+                                         pos-module-source
+                                         neg-blame-id
+                                         #,(id->contract-src-info #'id))))))])
+               (when key
+                 (hash-set! saved-id-table key lifted-id))
+               ;; Expand to a use of the lifted expression:
+               (with-syntax ([saved-id (syntax-local-introduce lifted-id)])
+                 (syntax-case stx (set!)
+                   [name
+                    (identifier? (syntax name))
+                    (syntax saved-id)]
+                   [(set! id arg) 
+                    (raise-syntax-error 'provide/contract
+                                        "cannot set! a contracted variable" 
+                                        stx 
+                                        (syntax id))]
+                   [(name . more)
+                    (with-syntax ([app (datum->syntax stx '#%app)])
+                      (syntax/loc stx (app saved-id . more)))]))))
+           ;; In case of partial expansion for module-level and internal-defn contexts,
+           ;; delay expansion until it's a good time to lift expressions:
+           (quasisyntax/loc stx (#%expression #,stx)))))))
 
 ;                                                                                                    
 ;                                                                                                    
@@ -136,37 +177,6 @@ improve method arity mismatch contract violation error messages?
 
 (define-syntax-parameter current-contract-region #f)
 
-(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id)
-  (make-set!-transformer
-   (lambda (stx)
-     (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region)
-                                     #'(#%variable-reference))]
-                   [pos-blame-id pos-blame-id]
-                   [contract-id contract-id]
-                   [id id])
-       (syntax-case stx (set!)
-         [(set! id arg)
-          (raise-syntax-error 'with-contract
-                              "cannot set! a with-contract variable"
-                              stx
-                              (syntax id))]
-         [(f arg ...)
-          (syntax/loc stx
-            ((-contract contract-id
-                        id
-                        pos-blame-id
-                        neg-blame-id
-                        #'f)
-             arg ...))]
-         [ident
-          (identifier? (syntax ident))
-          (syntax/loc stx
-            (-contract contract-id
-                       id
-                       pos-blame-id
-                       neg-blame-id
-                       #'ident))])))))
-
 (define-for-syntax (head-expand-all body-stxs)
   (for/list ([stx body-stxs])
     (local-expand stx
@@ -265,7 +275,7 @@ improve method arity mismatch contract violation error messages?
                      (values unprotected-id ... protected-id ...))))
                contract-def ...
                (define-syntax protected-id
-                 (make-with-contract-transformer 
+                 (make-contracted-transformer 
                   (quote-syntax contract)
                   (quote-syntax id)
                   blame-str)) ...)))))]
@@ -332,48 +342,6 @@ improve method arity mismatch contract violation error messages?
                               provide-stx
                               id)))))
 
-(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
-  (make-set!-transformer
-   (let ([saved-id-table (make-hasheq)])
-     (λ (stx)
-       (if (eq? 'expression (syntax-local-context))
-           ;; In an expression context:
-           (let ([key (syntax-local-lift-context)])
-             ;; Already lifted in this lifting context?
-             (let ([lifted-id
-                    (or (hash-ref saved-id-table key #f)
-                        ;; No: lift the contract creation:
-                        (with-syntax ([contract-id contract-id]
-                                      [id id]
-                                      [pos-module-source pos-module-source])
-                          (syntax-local-introduce
-                           (syntax-local-lift-expression
-                            #`(-contract contract-id
-                                         id
-                                         pos-module-source
-                                         (#%variable-reference)
-                                         #,(id->contract-src-info #'id))))))])
-               (when key
-                 (hash-set! saved-id-table key lifted-id))
-               ;; Expand to a use of the lifted expression:
-               (with-syntax ([saved-id (syntax-local-introduce lifted-id)])
-                 (syntax-case stx (set!)
-                   [name
-                    (identifier? (syntax name))
-                    (syntax saved-id)]
-                   [(set! id arg) 
-                    (raise-syntax-error 'provide/contract
-                                        "cannot set! a provide/contract variable" 
-                                        stx 
-                                        (syntax id))]
-                   [(name . more)
-                    (with-syntax ([app (datum->syntax stx '#%app)])
-                      (syntax/loc stx (app saved-id . more)))]))))
-           ;; In case of partial expansion for module-level and internal-defn contexts,
-           ;; delay expansion until it's a good time to lift expressions:
-           (quasisyntax/loc stx (#%expression #,stx)))))))
-
-
 ;; (provide/contract p/c-ele ...)
 ;; p/c-ele = (id expr) | (rename id id expr) | (struct id (id expr) ...)
 ;; provides each `id' with the contract `expr'.
@@ -861,9 +829,9 @@ improve method arity mismatch contract violation error messages?
                                           (list)
                                           (list #'(define contract-id (verify-contract 'provide/contract ctrct))))
                                    (define-syntax id-rename
-                                     (make-provide/contract-transformer (quote-syntax contract-id)
-                                                                        (quote-syntax id)
-                                                                        (quote-syntax pos-module-source)))
+                                     (make-contracted-transformer (quote-syntax contract-id)
+                                                                  (quote-syntax id)
+                                                                  (quote-syntax pos-module-source)))
                                    
                                    (provide (rename-out [id-rename external-name]))))])
                   
diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss
index 153ee41e5a..0279f549ab 100644
--- a/collects/scribble/base-render.ss
+++ b/collects/scribble/base-render.ss
@@ -405,33 +405,70 @@
 
     ;; ----------------------------------------
 
+    (define copied-srcs (make-hash))
+    (define copied-dests (make-hash))
+
     (define/public (install-file fn)
       (if refer-to-existing-files
           (if (string? fn)
               (string->path fn)
               fn)
-          (let ([src-dir (path-only fn)]
-                [dest-dir (get-dest-directory #t)]
-                [fn (file-name-from-path fn)])
-            (let ([src-file (build-path (or src-dir (current-directory)) fn)]
-                  [dest-file (build-path (or dest-dir (current-directory)) fn)])
-              (unless (and (file-exists? dest-file)
-                           (call-with-input-file*
-                            src-file
-                            (lambda (src)
-                              (call-with-input-file* 
-                               dest-file
-                               (lambda (dest)
-                                 (or (equal? (port-file-identity src)
-                                             (port-file-identity dest))
-                                     (let loop ()
-                                       (let ([s (read-bytes 4096 src)]
-                                             [d (read-bytes 4096 dest)])
-                                         (and (equal? s d)
-                                              (or (eof-object? s) (loop)))))))))))
-                (when (file-exists? dest-file) (delete-file dest-file))
-                (copy-file src-file dest-file))
-              (path->string fn)))))
+          (let ([normalized (normal-case-path (simplify-path (path->complete-path fn)))])
+            (or (hash-ref copied-srcs normalized #f)
+                (let ([src-dir (path-only fn)]
+                      [dest-dir (get-dest-directory #t)]
+                      [fn (file-name-from-path fn)])
+                  (let ([src-file (build-path (or src-dir (current-directory)) fn)]
+                        [dest-file (build-path (or dest-dir (current-directory)) fn)]
+                        [next-file-name (lambda (dest)
+                                          (let-values ([(base name dir?) (split-path dest)])
+                                            (build-path
+                                             base
+                                             (let ([s (path-element->string (path-replace-suffix name #""))])
+                                               (let ([n (regexp-match #rx"^(.*)_([0-9]+)$" s)])
+                                                 (format "~a_~a~a"
+                                                         (if n (cadr n) s)
+                                                         (if n (add1 (string->number (caddr n))) 2)
+                                                         (let ([ext (filename-extension name)])
+                                                           (if ext
+                                                               (bytes-append #"." ext)
+                                                               ""))))))))])
+                    (let-values ([(dest-file normalized-dest-file)
+                                  (let loop ([dest-file dest-file])
+                                    (let ([normalized-dest-file 
+                                           (normal-case-path (simplify-path (path->complete-path dest-file)))])
+                                      (if (file-exists? dest-file)
+                                          (cond
+                                           [(call-with-input-file*
+                                             src-file
+                                             (lambda (src)
+                                               (call-with-input-file* 
+                                                dest-file
+                                                (lambda (dest)
+                                                  (or (equal? (port-file-identity src)
+                                                              (port-file-identity dest))
+                                                      (let loop ()
+                                                        (let ([s (read-bytes 4096 src)]
+                                                              [d (read-bytes 4096 dest)])
+                                                          (and (equal? s d)
+                                                               (or (eof-object? s) (loop))))))))))
+                                            ;; same content at that destination
+                                            (values dest-file normalized-dest-file)]
+                                           [(hash-ref copied-dests normalized-dest-file #f)
+                                            ;; need a different file
+                                            (loop (next-file-name dest-file))]
+                                           [else
+                                            ;; replace the file
+                                            (delete-file dest-file)
+                                            (values dest-file normalized-dest-file)])
+                                          ;; new file
+                                          (values dest-file normalized-dest-file))))])
+                      (unless (file-exists? dest-file)
+                        (copy-file src-file dest-file))
+                      (hash-set! copied-dests normalized-dest-file #t)
+                      (let ([result (path->string (file-name-from-path dest-file))])
+                        (hash-set! copied-srcs normalized result)
+                        result))))))))
 
     ;; ----------------------------------------
 
diff --git a/collects/scribblings/gui/area-container-intf.scrbl b/collects/scribblings/gui/area-container-intf.scrbl
index 11d83be8e8..75e3cc16d6 100644
--- a/collects/scribblings/gui/area-container-intf.scrbl
+++ b/collects/scribblings/gui/area-container-intf.scrbl
@@ -71,7 +71,8 @@ Gets or sets the border margin for the container in pixels. This
 }
 
 
-@defmethod[(change-children [filter ((listof (is-a?/c subarea<%>)) . -> . (listof (is-a?/c subarea<%>)))])
+@defmethod[(change-children [filter ((listof (is-a?/c subarea<%>)) 
+                                     . -> . (listof (is-a?/c subarea<%>)))])
            void?]{
 
 Takes a filter procedure and changes the container's list of
diff --git a/collects/scribblings/gui/color-class.scrbl b/collects/scribblings/gui/color-class.scrbl
index 118d78f130..07eb8a6582 100644
--- a/collects/scribblings/gui/color-class.scrbl
+++ b/collects/scribblings/gui/color-class.scrbl
@@ -13,14 +13,16 @@ See @scheme[color-database<%>] for information about obtaining a color
 object using a color name.
 
 
-@defconstructor*/make[(([red (integer-in 0 255)]
+@defconstructor*/make[(()
+                       ([red (integer-in 0 255)]
                         [green (integer-in 0 255)]
                         [blue (integer-in 0 255)])
                        ([color-name string?]))]{
 
 Creates a new color with the given RGB values, or matching the given
- color name (using ``black'' if the name is not recognized). See
- @scheme[color-database<%>] for more information on color names.
+ color name (using ``black'' if no color is given or if the name is
+ not recognized). See @scheme[color-database<%>] for more information
+ on color names.
 
 }
 
diff --git a/collects/scribblings/gui/win-overview.scrbl b/collects/scribblings/gui/win-overview.scrbl
index 84a55aa032..a187e14fad 100644
--- a/collects/scribblings/gui/win-overview.scrbl
+++ b/collects/scribblings/gui/win-overview.scrbl
@@ -355,8 +355,10 @@ with the following program:
                                      [alignment '(center center)]))
 
 (code:comment #, @t{Add @onscreen{Cancel} and @onscreen{Ok} buttons to the horizontal panel})
-(new button% [parent parent] [label "Cancel"])
-(new button% [parent parent] [label "Ok"])
+(new button% [parent panel] [label "Cancel"])
+(new button% [parent panel] [label "Ok"])
+(when (system-position-ok-before-cancel?)
+  (send panel #,(:: area-container<%> change-children) reverse))
 
 (code:comment #, @t{Show the dialog})
 (send dialog #,(:: dialog% show) #t)
diff --git a/collects/scribblings/reference/paths.scrbl b/collects/scribblings/reference/paths.scrbl
index e5dc1f5f1d..068983d6f1 100644
--- a/collects/scribblings/reference/paths.scrbl
+++ b/collects/scribblings/reference/paths.scrbl
@@ -65,7 +65,9 @@ Beware that the current locale might not encode every string, in which
 case @scheme[string->path] can produce the same path for different
 @scheme[str]s. See also @scheme[string->path-element], which should be
 used instead of @scheme[string->path] when a string represents a
-single path element.}
+single path element.
+
+See also @scheme[string->some-system-path].}
 
 @defproc[(bytes->path [bstr bytes?]
                       [type (or/c 'unix 'windows) (system-path-convention-type)]) 
@@ -97,7 +99,9 @@ Furthermore, for display and sorting based on individual path elements
 (such as pathless file names), use @scheme[path-element->string],
 instead, to avoid special encodings use to represent some relative
 paths. See @secref["windowspaths"] for specific information about
-the conversion of Windows paths.}
+the conversion of Windows paths.
+
+See also @scheme[some-system-path->string].}
 
 @defproc[(path->bytes [path path?]) bytes?]{
 
@@ -494,21 +498,22 @@ to the end.}
 
 @note-lib[scheme/path]
 
-@defproc[(explode-path [path path-string?]) 
-         (listof (or/c path? 'up 'same))]{
+@defproc[(explode-path [path (or/c path-string? path-for-some-system?)]) 
+         (listof (or/c path-for-some-system? 'up 'same))]{
 
 Returns the list of path element that constitute @scheme[path].  If
 @scheme[path] is simplified in the sense of @scheme[simple-form-path],
 then the result is always a list of paths, and the first element of
 the list is a root.}
 
-@defproc[(file-name-from-path [path path-string?]) (or/c path? #f)]{
+@defproc[(file-name-from-path [path (or/c path-string? path-for-some-system?)])
+         (or/c path-for-some-system? #f)]{
 
 Returns the last element of @scheme[path]. If @scheme[path]
 syntactically a directory path (see @scheme[split-path]), then then
 result is @scheme[#f].}
 
-@defproc[(filename-extension [path path-string?]) 
+@defproc[(filename-extension [path (or/c path-string? path-for-some-system?)])
          (or/c bytes? #f)]{
 
 Returns a byte string that is the extension part of the filename in
@@ -516,7 +521,9 @@ Returns a byte string that is the extension part of the filename in
 syntactically a directory (see @scheme[split-path]) or if the path has
 no extension, @scheme[#f] is returned.}
 
-@defproc[(find-relative-path [base path-string?][path path-string?]) path?]{
+@defproc[(find-relative-path [base (or/c path-string? path-for-some-system?)]
+                             [path (or/c path-string?  path-for-some-system?)])
+         path-for-some-system?]{
 
 Finds a relative pathname with respect to @scheme[basepath] that names
 the same file or directory as @scheme[path]. Both @scheme[basepath]
@@ -544,10 +551,12 @@ An error is signaled by @scheme[normalize-path] if the input
 path contains an embedded path for a non-existent directory,
 or if an infinite cycle of soft links is detected.}
 
-@defproc[(path-only [path path-string?]) (or/c path? #f)]{
+@defproc[(path-only [path (or/c path-string? path-for-some-system?)])
+         path-for-some-system?]{
 
 If @scheme[path] is a filename, the file's path is returned. If
-@scheme[path] is syntactically a directory, @scheme[#f] is returned.}
+@scheme[path] is syntactically a directory, @scheme[path] is returned
+(as a path, if it was a string).}
 
 @defproc[(simple-form-path [path path-string?]) path?]{
 
@@ -555,6 +564,27 @@ Returns @scheme[(simplify-path (path->complete-path path))], which
 ensures that the result is a complete path containing no up- or
 same-directory indicators.}
 
+@defproc[(some-system-path->string [path path-for-some-system?])
+         string?]{
+
+Converts @scheme[path] to a string using a UTF-8 encoding of the
+path's bytes.
+
+Use this function when working with paths for a different system
+(whose encoding of pathnames might be unrelated to the current
+locale's encoding) and when starting and ending with strings.}
+
+@defproc[(string->some-system-path [str string?]
+                                   [kind (or/c 'unix 'windows)])
+         path-for-some-system?]{
+
+Converts @scheme[str] to a @scheme[kind] path using a UTF-8 encoding
+of the path's bytes.
+
+Use this function when working with paths for a different system
+(whose encoding of pathnames might be unrelated to the current
+locale's encoding) and when starting and ending with strings.}
+
 @;------------------------------------------------------------------------
 @include-section["unix-paths.scrbl"]
 @include-section["windows-paths.scrbl"]
diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl
index a7183c2278..9ca81d5210 100644
--- a/collects/scribblings/reference/stx-trans.scrbl
+++ b/collects/scribblings/reference/stx-trans.scrbl
@@ -340,6 +340,24 @@ eventually expanded in an expression context.
 @transform-time[]}
 
 
+@defproc[(syntax-local-lift-require [quoted-raw-require-spec any/c][stx syntax?])
+         syntax?]{
+
+Lifts a @scheme[#%require] form corresponding to
+@scheme[quoted-raw-require-spec] to the top-level or to the top of the
+module currently being expanded, wrapping it with @scheme[for-meta] if
+the current expansion context is not @tech{phase level} 0.
+
+The resulting syntax object is the same as @scheme[stx], except that a
+fresh @tech{syntax mark} is added. The same @tech{syntax mark} is
+added to the lifted @scheme[#%require] form, so that the
+@scheme[#%require] form can bind uses of imported identifiers in the
+resulting syntax object (assuming that the lexical information of
+@scheme[stx] includes the binding environment into which the
+@scheme[#%require] is lifted).
+
+@transform-time[]}
+
 @defproc[(syntax-local-name) (or/c symbol? #f)]{
 
 Returns an inferred name for the expression position being
diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl
index 77ed5e2701..59b70b3eaa 100644
--- a/collects/scribblings/reference/syntax.scrbl
+++ b/collects/scribblings/reference/syntax.scrbl
@@ -606,7 +606,7 @@ export name, though the same binding can be specified with the
 multiple symbolic names.}
 
 
-@defform[(for-meta require-spec ...)]{See @scheme[require] and @scheme[provide].}
+@defform[(for-meta phase-level require-spec ...)]{See @scheme[require] and @scheme[provide].}
 @defform[(for-syntax require-spec ...)]{See @scheme[require] and @scheme[provide].}
 @defform[(for-template require-spec ...)]{See @scheme[require] and @scheme[provide].}
 @defform[(for-label require-spec ...)]{See @scheme[require] and @scheme[provide].}
diff --git a/collects/sirmail/readr.ss b/collects/sirmail/readr.ss
index 08553388dd..8ede4cd3e5 100644
--- a/collects/sirmail/readr.ss
+++ b/collects/sirmail/readr.ss
@@ -1018,7 +1018,7 @@
 	    (lambda (w e) 
 	      (purge-marked/update-headers)))
       (send global-keymap add-function "gc"
-	    (lambda (w e) (collect-garbage) (collect-garbage)))
+	    (lambda (w e) (collect-garbage) (collect-garbage) (dump-memory-stats)))
       (send global-keymap add-function "show-memory-graph"
 	    (lambda (w e) (show-memory-graph)))
       
diff --git a/collects/teachpack/2htdp/scribblings/server2.ss b/collects/teachpack/2htdp/scribblings/server2.ss
deleted file mode 100644
index 427a7c22ed..0000000000
--- a/collects/teachpack/2htdp/scribblings/server2.ss
+++ /dev/null
@@ -1,181 +0,0 @@
-#lang slideshow
-
-(require slideshow/pict)
-
-(define DELTA 80)
-(define FT 12)
-
-(define initialize "register")
-(define proc-msg "process")
-
-(define program 
-  (apply vl-append (map (lambda (t) (text t '() (- FT 2)))
-                        (list (format "(universe ~a ~a)" initialize proc-msg)))))
-
-(define Program 
-  (cc-superimpose 
-   (rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program)))
-   program))
-
-;; String Boolean -> Pict 
-(define (make-state0 txt b)
-  ;; create the basic state
-  (define t (text txt '() FT))
-  (cc-superimpose t (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t)))))
-
-(define (add-labeled-arrow nx locked lb-find closed lt-find txt)
-  (define-values (x0 y0) (lb-find nx locked))
-  (define-values (x1 y1) (lt-find nx closed))
-  (define lbl (text txt '() (- FT 2)))
-  (define wlbl (pict-width lbl))
-  (define hlbl (pict-height lbl))
-  (define x (- x0 (/ wlbl 2)))
-  (define y (+ y0 (/ ( - y1 y0 hlbl) 2)))
-  (pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl))
-
-(define (h-labeled-arrow t)
-  (define tock (text t '() (- FT 2)))
-  (define blk (blank (+ DELTA 4) 2))
-  (vc-append tock (pin-arrow-line 4.0 blk blk lc-find blk rc-find)))
-
-(define message (text "Message" '() FT))
-(define (make-Message)
-  (cc-superimpose message (rectangle (+ 20 (pict-width message)) (+ 30 (pict-height message)))))
-
-(define Message  (vc-append (make-Message) (arrowhead 4 (* 1/2 pi))))
-(define MessageK (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message)))
-(define MessageI (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message)))
-
-(define M (rb-superimpose Message (blank DELTA  DELTA))) 
-(define K (rb-superimpose MessageK (blank DELTA  DELTA)))
-(define I (rb-superimpose MessageI (blank DELTA  DELTA)))
-
-(define (make-arrows M lbl)
-  (define Tock (h-labeled-arrow lbl))
-  (values Tock (vc-append (blank DELTA (/ DELTA 2)) Tock M)))
-
-(define-values (TockM arrowsR) (make-arrows M proc-msg))
-(define-values (TockK arrowsL) (make-arrows K proc-msg))
-(define-values (init  arrows) (make-arrows I initialize))
-
-(define state0 (make-state0 "Server_0" #f))
-(define state2 (make-state0 "Server_N-1" #f))
-(define Univrs (hc-append (arrowhead 4 0) (cc-superimpose (cloud 160 80) (text "Universe" '() FT ))))
-(define dots   (vc-append
-                (blank (pict-width state2) (quotient (pict-height state2) 1))
-                (text "..." '() FT) 
-                (blank (pict-width state2) (* (pict-height state2)))
-                Univrs))
-
-(define states (list arrows
-                     state0
-                     arrowsL
-                     dots
-                     arrowsR
-                     state2 
-                     (h-labeled-arrow proc-msg)))
-
-(define bg (blank (+ (apply + (map pict-width states)) DELTA) (pict-height dots)))
-
-(define (center base state x)
-  (define w (pict-height state))
-  (define d (quotient (- (pict-height bg) w) 2))
-  (pin-over base x d state))
-
-(define x (* 1/2 DELTA))
-(define xx 
-  (foldl (lambda (f ls s)
-           (define y (center s f x))
-           (set! x (+ x ls))
-           y)
-         bg
-         states
-         (map pict-width states)))
-
-(define zz (ct-superimpose xx Program))
-
-(require mred/mred)
-
-(define the-image
-  (lt-superimpose 
-   (dc (lambda (dc x y)
-         (define-values (mx my) (cb-find zz MessageK))
-         (define-values (tx ty) (ct-find zz MessageK))
-         (define-values (ix iy) (ct-find zz MessageI))
-         (define-values (jx jy) (cb-find zz MessageI))
-         (define-values (sx sy) (lc-find zz Univrs))
-         (define-values (tockx tocky) (lb-find zz TockK))
-         (define-values (initx inity) (lb-find zz init))
-         (define (add-curve rx ry)
-           (set! dcp (make-object dc-path%))
-           (set! cx (max rx tx))
-           (set! cy (min ry ty))
-           (send dcp move-to tx ty)
-           (send dcp curve-to tx ty cx cy rx ry)
-           (send dc draw-path dcp))
-         (define dcp (make-object dc-path%))
-         ;; --- draw arc from Message to Server 
-         (define cx (min sx mx))
-         (define cy (max sy my))
-         (send dc set-smoothing 'aligned)
-         (send dcp move-to mx my)
-         (send dcp curve-to mx my cx cy sx sy)
-         (send dc draw-path dcp)
-         (set! dcp (make-object dc-path%))
-         (set! cx (min sx jx))
-         (set! cy (max sy jy))
-         (send dc set-smoothing 'aligned)
-         (send dcp move-to jx jy)
-         (send dcp curve-to jx jy cx cy sx sy)
-         (send dc draw-path dcp)
-;; --- draw arc from Message to Receiver 
-         (add-curve tockx tocky)
-         (set! tx ix) (set! ty iy)
-         (add-curve initx inity)
-         ;; --- 
-         dc)
-       (pict-width zz) (pict-height zz))
-   (lt-superimpose
-    zz
-    (dc (lambda (dc x y)
-          (define-values (mx my) (cb-find zz Message))
-          (define-values (tx ty) (ct-find zz Message))
-          (define-values (sx sy) (rc-find zz Univrs))
-          (define-values (tockx tocky) (rb-find zz TockM))
-          (define (add-curve rx ry)
-            (set! dcp (make-object dc-path%))
-            (set! cx (min rx tx))
-            (set! cy (min ry ty))
-            (send dcp move-to tx ty)
-            (send dcp curve-to tx ty cx cy rx ry)
-            (send dc draw-path dcp))
-          (define dcp (make-object dc-path%))
-          ;; --- draw arc from Message to Server 
-          (define cx (max sx mx))
-          (define cy (max sy my))
-          (send dc set-smoothing 'aligned)
-          (send dcp move-to mx my)
-          (send dcp curve-to mx my cx cy sx sy)
-          (send dc draw-path dcp)
-          ;; --- draw arc from Message to Receiver 
-          (add-curve tockx tocky)
-          ;; --- 
-          dc)
-        (pict-width zz) (pict-height zz)))))
-
-(define image-bm
-  (make-object bitmap% 
-    (inexact->exact (round (pict-width the-image)))
-    (inexact->exact (round (pict-height the-image)))))
-
-(send image-bm ok?)
-
-(define image-dc
-  (new bitmap-dc% [bitmap image-bm]))
-(send image-dc clear)
-
-(draw-pict the-image image-dc 0.0 0.0)
-
-(send image-bm save-file "server2.png" 'png)
-
-the-image
\ No newline at end of file
diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl
index 6609c611b4..3547e2a548 100644
--- a/collects/teachpack/2htdp/scribblings/universe.scrbl
+++ b/collects/teachpack/2htdp/scribblings/universe.scrbl
@@ -32,9 +32,9 @@
 
 This @tt{universe.ss} teachpack implements and provides the functionality
  for creating interactive, graphical programs that consist of plain
- mathematical functions. We refer to such programs as @defterm{world}
+ mathematical functions. We refer to such programs as @deftech{world}
  programs. In addition, world programs can also become a part of a
- @defterm{universe}, a collection of worlds that can exchange messages.
+ @deftech{universe}, a collection of worlds that can exchange messages.
 
 The purpose of this documentation is to give experienced Schemers and HtDP
  teachers a concise overview for using the library. The first part of the
@@ -42,7 +42,7 @@ The purpose of this documentation is to give experienced Schemers and HtDP
  presents an illustration of how to design such programs for a simple
  domain; it is suited for a novice who knows how to design conditional
  functions for symbols. The second half of the documentation focuses on
- @tech{universe} programs: how it is managed via a server, how @tech{world}
+ "universe" programs: how it is managed via a server, how @tech{world}
  programs register with the server, etc. The last two sections show how to
  design a simple universe of two communicating worlds. 
 
@@ -138,17 +138,17 @@ The following picture provides an intuitive overview of the workings of a
 
 @image["nuworld.png"]
 
- The @scheme[big-bang] form installs @scheme[World_0] as the initial
- world. The handlers @scheme[tock], @scheme[react], and @scheme[click] transform
+ The @scheme[big-bang] form installs @scheme[World_0] as the initial @tech{WorldState}.
+ The handlers @scheme[tock], @scheme[react], and @scheme[click] transform
  one world into another one; each time an event is handled, @scheme[done] is
  used to check whether the world is final, in which case the program is
  shut down; and finally, @scheme[draw] renders each world as a scene, which
  is then displayed on an external canvas. 
 
-@deftech{World} : @scheme[any/c]
+@deftech{WorldState} : @scheme[any/c]
 
 The design of a world program demands that you come up with a data
- definition of all possible states. We use @tech{World} to refer to
+ definition of all possible states. We use @tech{WorldState} to refer to
  this collection of data, using a capital W to distinguish it from the
  program.  In principle, there are no constraints on this data
  definition though it mustn't be an instance of the @tech{Package}
@@ -176,7 +176,7 @@ The design of a world program demands that you come up with a data
 
  starts a @tech{world} program in the initial state specified with
  @scheme[state-expr], which must of course evaluate to an element of
- @tech{World}.  Its behavior is specified via the handler functions
+ @tech{WorldState}.  Its behavior is specified via the handler functions
  designated in the optional @scheme[spec] clauses, especially how the
  @tech{world} program deals with clock ticks, with key events, with mouse
  events, and eventually with messages from the universe; how it renders
@@ -190,7 +190,7 @@ The design of a world program demands that you come up with a data
 @item{
 @defform[(on-tick tick-expr)
          #:contracts
-	 ([tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))])]{
+	 ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))])]{
 
 tell DrScheme to call the @scheme[tick-expr] function on the current
 world every time the clock ticks. The result of the call becomes the
@@ -199,7 +199,7 @@ current world. The clock ticks at the rate of 28 times per second.}}
 @item{
 @defform/none[(on-tick tick-expr rate-expr)
               #:contracts
-              ([tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))]
+              ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))]
                [rate-expr natural-number/c])]{
 tell DrScheme to call the @scheme[tick-expr] function on the current
 world every time the clock ticks. The result of the call becomes the
@@ -234,7 +234,7 @@ A character is used to signal that the user has hit an alphanumeric
 
 @defform[(on-key change-expr)
          #:contracts
-	  ([change-expr (-> (unsyntax @tech{World}) key-event? (unsyntax @tech{World}))])]{
+	  ([change-expr (-> (unsyntax @tech{WorldState}) key-event? (unsyntax @tech{WorldState}))])]{
  tell DrScheme to call @scheme[change-expr] function on the current world and a 
  @tech{KeyEvent} for every keystroke the user of the computer makes. The result
  of the call becomes the current world.
@@ -288,7 +288,7 @@ All @tech{MouseEvent}s are represented via symbols:
 @defform[(on-mouse clack-expr)
          #:contracts
 	 ([clack-expr 
-           (-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) (unsyntax @tech{World}))])]{
+           (-> (unsyntax @tech{WorldState}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) (unsyntax @tech{WorldState}))])]{
  tell DrScheme to call @scheme[clack-expr] on the current world, the current
  @scheme[x] and @scheme[y] coordinates of the mouse, and and a
  @tech{MouseEvent} for every (noticeable) action of the mouse by the
@@ -303,7 +303,7 @@ All @tech{MouseEvent}s are represented via symbols:
  
 @defform[(on-draw render-expr)
          #:contracts
-         ([render-expr (-> (unsyntax @tech{World}) scene?)])]{ 
+         ([render-expr (-> (unsyntax @tech{WorldState}) scene?)])]{ 
 
  tell DrScheme to call the function @scheme[render-expr] whenever the
  canvas must be drawn. The external canvas is usually re-drawn after DrScheme has
@@ -312,7 +312,7 @@ All @tech{MouseEvent}s are represented via symbols:
 
 @defform/none[(on-draw render-expr width-expr height-expr)
               #:contracts
-              ([render-expr (-> (unsyntax @tech{World}) scene?)]
+              ([render-expr (-> (unsyntax @tech{WorldState}) scene?)]
 	       [width-expr natural-number/c]
                [height-expr natural-number/c])]{ 
 
@@ -325,7 +325,7 @@ All @tech{MouseEvent}s are represented via symbols:
 
 @defform[(stop-when last-world?)
          #:contracts
-         ([last-world? (-> (unsyntax @tech{World}) boolean?)])]{
+         ([last-world? (-> (unsyntax @tech{WorldState}) boolean?)])]{
  tell DrScheme to call the @scheme[last-world?] function whenever the canvas is
  drawn. If this call produces @scheme[true], the world program is shut
           down. Specifically, the  clock is stopped; no more
@@ -436,7 +436,8 @@ it to the locked position; and}
 Simulating any dynamic behavior via a @tech{world} program demands two
  different activities. First, we must tease out those portions of our
  domain that change over time or in reaction to actions, and we must
- develop a data representation @deftech{D} for this information.  Keep in
+ develop a data representation for this information.  This is what we call
+ @tech{WorldState}. Keep in
  mind that a good data definition makes it easy for readers to map data to
  information in the real world and vice versa. For all others aspects of
  the world, we use global constants, including graphical or visual
@@ -447,7 +448,7 @@ Second, we must translate the actions in our domain---the arrows in the
  teachpack can deal with. Once we have decided to use the passing of time
  for one aspect, key presses for another, and mouse movements for a third,
  we must develop functions that map the current state of the
- world---represented as data from @tech{D}---into the next state of the
+ world---represented as data from @tech{WorldState}---into the next state of the
  world. Put differently, we have just created a wish list with three
  handler functions that have the following general contract and purpose
  statements:
@@ -455,16 +456,16 @@ Second, we must translate the actions in our domain---the arrows in the
 @(begin
 #reader scribble/comment-reader
 (schemeblock
-;; tick : @tech{D} -> @tech{D}
+;; tick : WorldState -> WorldState
 ;; deal with the passing of time 
 (define (tick w) ...)
 
-;; click : @tech{D} @emph{Number} @emph{Number} @tech{MouseEvent} -> @tech{D}
+;; click : WorldState @emph{Number} @emph{Number} @tech{MouseEvent} -> WorldState
 ;; deal with a mouse click at @emph{(x,y)} of kind @emph{me}
 ;; in the current world @emph{w}
 (define (click w x y me) ...)
 
-;; control : @tech{D} @tech{KeyEvent} -> @tech{D}
+;; control : WorldState @tech{KeyEvent} -> WorldState
 ;; deal with a key event (symbol, char) @emph{ke}
 ;; in the current world @emph{w}
 (define (control w ke) ...)
@@ -487,15 +488,14 @@ Our first and immediate goal is to represent the world as data. In this
  the door is whether it is locked, unlocked but closed, or open. We use
  three symbols to represent the three states:
 
-@deftech{SD} : state of door 
-
 @(begin
 #reader scribble/comment-reader
 (schemeblock
-;; The state of the door (SD) is one of: 
+;; WorldState is one of: 
 ;; -- @scheme['locked]
 ;; -- @scheme['closed]
 ;; -- @scheme['open]
+;; interpretation: state of door 
 ))
 
 Symbols are particularly well-suited here because they directly express
@@ -535,14 +535,14 @@ a visible scene.}
 
 ]
 
-Let's start with @emph{automatic-closer}. Substituting @tech{SD} for
-@tech{D} and @emph{automatic-closer} for @emph{tick}, we get its contract,
+Let's start with @emph{automatic-closer}. Since @emph{automatic-closer}
+acts as the @scheme[on-tick] handler, we get its contract, 
 and it is easy to refine the purpose statement, too:
 
 @(begin
 #reader scribble/comment-reader
 (schemeblock
-;; automatic-closer : @tech{SD} -> @tech{SD}
+;; automatic-closer : WorldState -> WorldState
 ;; closes an open door over the period of one tick 
 (define (automatic-closer state-of-door) ...)
 ))
@@ -560,7 +560,7 @@ and it is easy to refine the purpose statement, too:
 @(begin
 #reader scribble/comment-reader
 (schemeblock
-;; automatic-closer : @tech{SD} -> @tech{SD}
+;; automatic-closer : WorldState -> WorldState
 ;; closes an open door over the period of one tick 
 
 (check-expect (automatic-closer 'locked) 'locked)
@@ -604,7 +604,7 @@ For the remaining three arrows of the diagram, we design a function that
 @(begin
 #reader scribble/comment-reader
 (schemeblock
-;; door-actions : @tech{SD} @tech{KeyEvent} -> @tech{SD}
+;; door-actions : WorldState @tech{KeyEvent} -> WorldState
 ;; key events simulate actions on the door 
 (define (door-actions s k) ...)
 ))
@@ -644,7 +644,7 @@ purpose:
 @(begin
 #reader scribble/comment-reader
 (schemeblock
-;; render : @tech{SD} -> @tech{scene}
+;; render : WorldState -> @tech{scene}
 ;; translate the current state of the door into a large text 
 (define (render s)
   (text (symbol->string s) 40 'red))
@@ -719,9 +719,9 @@ Note the last clause includes @scheme[empty] of course.
 
 Each world-producing callback in a world program---those for handling clock
  tick events, keyboard events, and mouse events---may produce a
- @tech{Package} in addition to just a @tech{World}. 
+ @tech{Package} in addition to just a @tech{WorldState}. 
 
-@deftech{Package} represents a pair consisting of a @tech{World} (state)
+@deftech{Package} represents a pair consisting of a @tech{WorldState}
  and a message from a @tech{world} program to the @tech{server}.  Because
  programs only send messages via @tech{Package}, the teachpack does not
  provide the selectors for the structure, only the constructor and a
@@ -731,38 +731,38 @@ Each world-producing callback in a world program---those for handling clock
  determine whether @scheme[x] is a @tech{Package}.}
 
 @defproc[(make-package [w any/c][m sexp?]) package?]{
- create a @tech{Package} from a @tech{World} and an @tech{S-expression}.}
+ create a @tech{Package} from a @tech{WorldState} and an @tech{S-expression}.}
 
-As mentioned, all event handlers may return @tech{World}s or @tech{Package}s;
+As mentioned, all event handlers may return @tech{WorldState}s or @tech{Package}s;
 here are the revised specifications: 
 
 @defform/none[(on-tick tick-expr)
               #:contracts
-              ([tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))])]{
+              ([tick-expr (-> (unsyntax @tech{WorldState}) (or/c (unsyntax @tech{WorldState}) package?))])]{
 } 
 
 @defform/none[(on-tick tick-expr rate-expr)
               #:contracts
-              ([tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))]
+              ([tick-expr (-> (unsyntax @tech{WorldState}) (or/c (unsyntax @tech{WorldState}) package?))]
                [rate-expr natural-number/c])]{
 }
 
 @defform/none[(on-key change-expr)
               #:contracts
-              ([change-expr (-> (unsyntax @tech{World}) key-event? (or/c (unsyntax @tech{World}) package?))])]{
+              ([change-expr (-> (unsyntax @tech{WorldState}) key-event? (or/c (unsyntax @tech{WorldState}) package?))])]{
 }
 
 @defform/none[(on-mouse clack-expr)
               #:contracts
               ([clack-expr
-                (-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent})
-                    (or/c (unsyntax @tech{World}) package?))])]{
+                (-> (unsyntax @tech{WorldState}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent})
+                    (or/c (unsyntax @tech{WorldState}) package?))])]{
 }
 
 If one of these event handlers produces a @tech{Package}, the content of the world
  field becomes the next world and the message field specifies what the
  world sends to the universe. This distinction also explains why the data
- definition for @tech{World} may not include a @tech{Package}.
+ definition for @tech{WorldState} may not include a @tech{Package}.
 
 @subsection{Connecting with the Universe}
 
@@ -823,28 +823,28 @@ The @scheme[on-receive] clause of a @scheme[big-bang] specifies the event handle
 
 @defform[(on-receive receive-expr)
          #:contracts
-	 ([receive-expr (-> (unsyntax @tech{World}) sexp? (or/c (unsyntax @tech{World}) package?))])]{
+	 ([receive-expr (-> (unsyntax @tech{WorldState}) sexp? (or/c (unsyntax @tech{WorldState}) package?))])]{
  tell DrScheme to call @scheme[receive-expr] for every message receipt, on the current
- @tech{World} and the received message. The result of the call becomes the current
- @tech{World}. 
+ @tech{WorldState} and the received message. The result of the call becomes the current
+ @tech{WorldState}. 
 
  Because @scheme[receive-expr] is (or evaluates to) a world-transforming
  function, it too can produce a @tech{Package} instead of just a
- @tech{World}. If the result is a @tech{Package}, its message content is
+ @tech{WorldState}. If the result is a @tech{Package}, its message content is
  sent to the @tech{server}.}
 
 The diagram below summarizes the extensions of this section in graphical form. 
 
-@image["universe.png"]
+@image["world.png"]
 
 A registered world program may send a message to the universe server
  at any time by returning a @tech{Package} from an event handler. The
  message is transmitted to the server, which may forward it to some
  other world program as given or in some massaged form. The arrival of a
  message is just another event that a world program must deal with. Like
- all other event handlers @emph{receive} accepts a @tech{World} and some
+ all other event handlers @emph{receive} accepts a @tech{WorldState} and some
  auxiliary arguments (a message in this case) and produces a
- @tech{World} or a @tech{Package}.
+ @tech{WorldState} or a @tech{Package}.
 
 When messages are sent from any of the worlds to the universe or vice versa,
  there is no need for the sender and receiver to synchronize. Indeed, a sender
@@ -853,16 +853,15 @@ When messages are sent from any of the worlds to the universe or vice versa,
  the receiving @tech{server} or @tech{world} program take care of them. 
 
 @; -----------------------------------------------------------------------------
-
 @section[#:tag "universe-server"]{The Universe Server}
 
 A @deftech{server} is the central control program of a @tech{universe} and
  deals with receiving and sending of messages between the world
  programs that participate in the @tech{universe}. Like a @tech{world}
  program, a server is a program that reacts to events, though to different
- events. There are two primary kinds of events: when a new @tech{world}
- program joins the @tech{universe} that the server controls and when a
- @tech{world} sends a message. 
+ events than @tech{world}s. The two primary kinds of events are the
+ appearance of a new @tech{world} program in the @tech{universe} 
+ and the receipt of a message from a @tech{world} program. 
 
 The teachpack provides a mechanism for designating event handlers for
  servers that is quite similar to the mechanism for describing @tech{world}
@@ -897,8 +896,9 @@ This section first introduces some basic forms of data that the
 @; -----------------------------------------------------------------------------
 @subsection{Worlds and Messages}
 
-Understanding the server's event handling functions demands three
- concepts. 
+Understanding the server's event handling functions demands several data
+ representations: that of (a connection to) a @tech{world} program and that
+ of a response of a handler to an event. 
 
 @itemize[
 
@@ -915,6 +915,9 @@ Understanding the server's event handling functions demands three
 @defproc[(world=? [u world?][v world?]) boolean?]{
  compares two @emph{world}s for equality.}
 
+@defproc[(world-name [w world?]) symbol?]{
+ extracts the name from a @emph{world} structure.}
+
 @defthing[world1 world?]{a world for testing your programs}
 @defthing[world2 world?]{another world for testing your programs}
 @defthing[world3 world?]{and a third one}
@@ -928,9 +931,20 @@ for universe programs. For example:
 ]
 }
 
-@item{A @emph{mail} represents a message from an event handler to a
-world. The teachpack provides only a predicate and a constructor for these
-structures:
+@item{Each event handler produces a @emph{bundle}, which is a structure
+ that contains the list of @emph{world}s to keep track of; the
+ @tech{server}'s remaining state; and a list of mails to other
+ worlds: 
+
+@defproc[(bundle? [x any/c]) boolean?]{
+ determines whether @scheme[x] is a @emph{bundle}.}
+
+@defproc[(make-bundle [low (listof world?)] [state any/c] [mails (listof mail?)]) bundle?]{
+ creates a @emph{bundle} from a list of worlds, a piece of data that represents a server
+ state, and a list of mails.}
+
+A @emph{mail} represents a message from an event handler to a world. The
+teachpack provides only a predicate and a constructor for these structures:
 
 @defproc[(mail? [x any/c]) boolean?]{
  determines whether @scheme[x] is a @emph{mail}.}
@@ -939,33 +953,22 @@ structures:
  creates a @emph{mail} from a @emph{world} and an @tech{S-expression}.}
 }
 
-@item{Each event handler produces a @emph{bundle}, which is a structure
-that contains the @tech{server}'s state and a list of mails to other
-worlds. Again, the teachpack provides only the predicate and a constructor: 
-
-@defproc[(bundle? [x any/c]) boolean?]{
- determines whether @scheme[x] is a @emph{bundle}.}
-
-@defproc[(make-bundle [state any/c] [mails (listof mail?)]) bundle?]{
- creates a @emph{bundle} from a piece of data that represents a server
- state and a list of mails.}
-
-}
 ]
 
 @; -----------------------------------------------------------------------------
 @subsection{Universe Descriptions}
 
 A @tech{server} keeps track of information about the @tech{universe} that
- it manages. Of course, what kind of information it tracks and how it is
- represented depends on the situation and the programmer, just as with
- @tech{world} programs. 
+ it manages. One kind of tracked information is obviously the collection of
+ participating world programs, but in general the kind of information that
+ a server tracks and how the information is represented depends on the
+ situation and the programmer, just as with @tech{world} programs.
 
-@deftech{Universe} @scheme[any/c] represent the server's state For running
+@deftech{UniverseState} @scheme[any/c] represents the server's state For running
 @tech{universe}s, the teachpack demands that you come up with a data
 definition for (your state of the) @tech{server}.  Any piece of data can
 represent the state. We just assume that you introduce a data definition
-for the possible states and that your transformation functions are designed
+for the possible states and that your event handlers are designed
 according to the design recipe for this data definition.
 
 The @tech{server} itself is created with a description that includes the
@@ -993,7 +996,7 @@ registration of new worlds, how it disconnects worlds, how it sends
 messages from one world to the rest of the registered worlds, and how it
 renders its current state as a string.}
 
-A @scheme[universe] expression starts a server. Visually it opens
+Evaluating a @scheme[universe] expression starts a server. Visually it opens
  a console window on which you can see that worlds join, which messages are
  received from which world, and which messages are sent to which world. For
  convenience, the console also has two buttons: one for shutting down a
@@ -1001,35 +1004,48 @@ A @scheme[universe] expression starts a server. Visually it opens
  especially useful during the integration of the various pieces of a
  distributed program. 
 
-
-Now it is possible to explain the clauses in a @scheme[universe] server
-description. Two of them are mandatory: 
+The mandatory clauses of a @scheme[universe] server description are
+@scheme[on-new] and @scheme[on-msg]: 
 
 @itemize[
 
 @item{
  @defform[(on-new new-expr)
           #:contracts
-          ([new-expr (-> (unsyntax @tech{Universe}) world? 
-	   	         (cons (unsyntax @tech{Universe}) [listof mail?]))])]{
+          ([new-expr (-> [listof world?] (unsyntax @tech{UniverseState}) world? bundle?)])]{
  tell DrScheme to call the function @scheme[new-expr] every time another world joins the
- universe.}}
+ universe. The event handler is called on the current list of worlds and the
+ joining world, which isn't on the list yet. In particular, the handler may
+ reject a @tech{world} program from participating in a @tech{universe},
+ simply by not including it in the resulting @scheme[bundle] structure. The
+ handler may still send one message to the world that attempts to join. }
+}
 
 @item{
  @defform[(on-msg msg-expr)
           #:contracts
-          ([msg-expr (-> (unsyntax @tech{Universe}) world? sexp? 
-	   	         (cons (unsyntax @tech{Universe}) [listof mail?]))])]{
+          ([msg-expr (-> [listof world?] (unsyntax @tech{UniverseState}) world? sexp? bundle?)])]{
 
- tell DrScheme to apply @scheme[msg-expr] to the current state of the universe, the world
- that sent the message, and the message itself. The handler must produce a state of the
- universe and a list of mails.}
+ tell DrScheme to apply @scheme[msg-expr] to the list of currently
+ participating worlds @scheme[low], the current state of the universe, the world
+ @scheme[w] that sent the message, and the message itself. Note that
+ @scheme[w] is guaranteed to be on the list @scheme[low]. 
  }
-]
+}]
+
+ All proper event handlers produce a @emph{bundle}. The list of worlds in
+ this @emph{bundle} becomes the server's list of worlds, meaning that only
+ the server listens only to messages from "approved" worlds.  The state in
+ the bundle is safe-guarded by the server until the next event, and the
+ mails are broadcast as specified.
 
 The following picture provides a graphical overview of the server's workings. 
 
-@image["server2.png"]
+@; -----------------------------------------------------------------------------
+@;; THE PICTURE IS WRONG
+@; -----------------------------------------------------------------------------
+
+@image["server.png"]
 
 In addition to the mandatory handlers, a program may wish to add some
 optional handlers: 
@@ -1039,36 +1055,37 @@ optional handlers:
 @item{
 @defform/none[(on-tick tick-expr)
               #:contracts
-              ([tick-expr (-> (unsyntax @tech{Universe}) bundle?)])]{
- tell DrScheme to apply @scheme[tick-expr] to the current state of the
- universe. The handler is expected to produce a bundle of the new state of
- the universe and a list of mails. 
+              ([tick-expr (-> [listof world?] (unsyntax @tech{UniverseState}) bundle?)])]{
+ tell DrScheme to apply @scheme[tick-expr] to the current list of
+ participating worlds and the current state of the
+ universe. 
  }
 
 @defform/none[(on-tick tick-expr rate-expr)
               #:contracts
-              ([tick-expr (-> (unsyntax @tech{Universe}) bundle?)]
+              ([tick-expr (-> [listof world?] (unsyntax @tech{UniverseState}) bundle?)]
                [rate-expr natural-number/c])]{ 
  tell DrScheme to apply @scheme[tick-expr] as above but use the specified
  clock tick rate instead of the default.
  }
+
 }
 
 @item{
  @defform[(on-disconnect dis-expr)
           #:contracts
-          ([dis-expr (-> (unsyntax @tech{Universe}) world? bundle?)])]{
+          ([dis-expr (-> [listof world?] (unsyntax @tech{UniverseState}) world? bundle?)])]{
  tell DrScheme to invoke @scheme[dis-expr] every time a participating
- @tech{world} drops its connection to the server. The first argument is the
- current state of the universe; the second one is the world that got
- disconnected. 
+ @tech{world} drops its connection to the server. The first two arguments
+ are the current list of participating worlds and the state of the
+ universe; the third one is the world that got disconnected. 
  }
 }
 
 @item{
  @defform[(to-string render-expr)
           #:contracts
-          ([render-expr (-> (unsyntax @tech{Universe}) string?)])]{
+          ([render-expr (-> [listof world?] (unsyntax @tech{UniverseState}) string?)])]{
  tell DrScheme to render the state of the universe after each event and to
  display this string in the universe console. 
  }
@@ -1110,19 +1127,26 @@ The first step in designing a @tech{universe} is to understand the
  throughout a system. We know that the @tech{universe} doesn't exist until
  the server starts and the @tech{world}s are joining. Because of the nature
  of computers and networks, however, we may assume little else. Our network
- connections ensure that if some @tech{world} sends two messages in some
- order, they arrive in the same order at the server. In contrast, it is
- generally impossible to ensure whether one world joins before another or
- whether a message from one world gets to the server before another world's
- message gets there. It is therefore the designer's task to establish a
- protocol that enforces a certain order onto a universe and this activity
- is called @emph{protocol design}. 
+ connections ensure that if some @tech{world} or the @tech{server} sends
+ two messages to the @emph{same} place in some order, they arrive in the
+ same order (if they arrive at all). In contrast, if two distinct
+ @tech{world} programs send one message each, the network does not
+ guarantee the order of arrival at the server; similarly, if the
+ @tech{server} is asked to send some messages to several distinct
+ @tech{world} programs, they may arrive at those worlds in the order sent
+ or in the some other order. In the same vein, it is impossible to ensure
+ that one world joins before another. Worst, when someone removes the
+ connection (cable, wireless) between a computer that runs a @tech{world}
+ program and the rest of the network or if some network cable is cut,
+ messages don't go anywhere. Due to this vagaries, it is therefore the
+ designer's task to establish a protocol that enforces a certain order onto
+ a universe and this activity is called @emph{protocol design}.
 
 From the perspective of the @tech{universe}, the design of a protocol is
  about the design of data representations for tracking universe information
  in the server and the participating worlds and the design of a data
  representation for messages. As for the latter, we know that they must be
- @tech{S-expression}s, but of course @tech{world} programs don't send all
+ @tech{S-expression}s, but usually @tech{world} programs don't send all
  kinds of @tech{S-expression}s. The data definitions for messages must
  therefore select a subset of suitable @tech{S-expression}s. As for the
  state of the server and the worlds, they must reflect how they currently
@@ -1134,14 +1158,14 @@ In summary, the first step of a protocol design is to introduce:
 @itemize[
 
 @item{a data definition for the information about the universe that the
-server tracks, call it @tech{Universe};} 
+server tracks, call it @tech{UniverseState};} 
 
 @item{a data definition for the world(s) about their current relationship
 to the universe;}
 
 @item{data definitions for the messages that are sent from the server to
-the worlds and vice versa. Let's call them @deftech{MsgS2W} for messages
-from the server to the worlds and @deftech{MsgW2S} for the other direction;
+the worlds and vice versa. Let's call them @deftech{S2W} for messages
+from the server to the worlds and @deftech{W2S} for the other direction;
 in the most general case you may need one pair per world.}
 ]
 
@@ -1161,7 +1185,22 @@ The second step of a protocol design is to figure out which major
  state of the world. A good tool for writing down these agreements is an
  interaction diagram. 
 
-(interaction diagrams: tbd)
+
+@verbatim{
+ 
+     Server              World1                  World2 
+       |                   |                       |
+       |   'go             |                       |
+       |<------------------|                       |
+       |    'go            |                       |
+       |------------------------------------------>|
+       |                   |                       |
+       |                   |                       |
+}
+
+ Each vertical line is the life line of a @tech{world} program or the
+ @tech{server}. Each horizontal arrow denotes a message sent from one
+ @tech{universe} participant to another. 
 
 The design of the protocol, especially the data definitions, have direct
 implications for the design of event handling functions. For example, in
@@ -1172,19 +1211,20 @@ translates into the design of two functions with the following headers,
 @(begin
 #reader scribble/comment-reader
 (schemeblock
-;; @tech{Universe} World -> (make-bundle @tech{Universe} [Listof mail?])
-;; create new @tech{Universe} when world w is joining the universe,
-;; which is in state s; also send mails as needed 
+;; Bundle is
+;;   (make-bundle [Listof world?] UniverseState [Listof mail?])
+
+;; [Listof world?] UniverseState world? -> Bundle 
+;; compute next list of worlds and new @tech{UniverseState} 
+;; when world w is joining the universe, which is in state s; 
 (define (add-world s w) ...)
 
-;; @tech{Universe} World MsgW2U -> (make-bundle @tech{Universe} [Listof mail?])
-;; create new @tech{Universe} when world w is sending message m 
-;; to universe in state s; also send mails as needed 
+;; [Listof world?] UniverseState world? W2U -> Bundle 
+;; compute next list of worlds and new @tech{UniverseState} 
+;; when world w is sending message m to universe in state s
 (define (process s p m) ...)
 ))
 
-Note how both functions return a bundle. 
-
 Finally, we must also decide how the messages affect the states of the
  worlds; which of their callback may send messages and when; and what to do
  with the messages a world receives. Because this step is difficult to
@@ -1204,10 +1244,14 @@ As for the server's state, it must obviously keep track of all @tech{world}s tha
  are passive. Of course, initially the @tech{universe} is empty, i.e., there are
  no @tech{world}s and, at that point, the server has nothing to track. 
 
-While there are many different useful ways of representing such a @tech{universe},
- we choose to introduce @tech{Universe} as a list of @tech{world}s, and we
- interpret non-empty lists as those where the first @tech{world} is active and the
- remainder are the passive @tech{world}s. As for the two possible events, 
+While there are many different useful ways of representing such a
+ @tech{universe}, we just use the list of @emph{worlds} that is handed to
+ each handler and that handlers return via their bundles. The
+ @tech{UniverseState} itself is useless for this trivial example. We
+ interpret non-empty lists as those where the first @tech{world} is active
+ and the remainder are the passive @tech{world}s. As for the two possible
+ events, 
+
 @itemize[
 
 @item{it is natural to add new @tech{world}s to the end of the list; and}
@@ -1239,6 +1283,34 @@ for this part of a @tech{world}'s state until we design its ``local'' behavior.}
  which it may ignore. When it is done with its turn, it will send a
  message. 
 
+@verbatim{
+     Server
+       |                 World1
+       |<==================|
+       |  'it-is-your-turn |
+       |------------------>|
+       |                   |                    World2 
+       |<==========================================|
+       |  'done            |                       |
+       |<------------------|                       |
+       |  'it-is-your-turn |                       |
+       |------------------------------------------>|
+       |                   |                       |
+       |                   |                       |
+       |  'done            |                       |
+       |<------------------------------------------|
+       |  'it-is-your-turn |                       |
+       |------------------>|                       |
+       |                   |                       |
+       |                   |                       |       
+}
+
+Here the double-lines (horizontal) denote the registration step, the others
+ are message exchanges. The diagram thus shows how the @tech{server}
+ decides to make the first registered world the active one and to enlist
+ all others as they join. 
+
+
 @; -----------------------------------------------------------------------------
 @subsection{Designing the Ball Server}
 
@@ -1249,7 +1321,7 @@ The preceding subsection dictates that our server program starts like this:
 [schemeblock
 ;; teachpack: universe.ss
   
-;; Universe is [Listof world?]
+;; UniverseState is '*
 ;; StopMessage is 'done. 
 ;; GoMessage is 'it-is-your-turn.
 ])
@@ -1264,24 +1336,23 @@ The preceding subsection dictates that our server program starts like this:
 @(begin
 #reader scribble/comment-reader
 [schemeblock
-;; Result is (make-bundle Universe (list (make-mail world? GoMessage)))
+;; Result is 
+;;   (make-bundle [Listof world?] '* (list (make-mail world? GoMessage)))
 
-;; Universe world? -> Result 
+;; [Listof world?] UniverseState world? -> Result 
 ;; add world w to the universe, when server is in state u
 (define (add-world u w) ...)
 
-;; Universe world? StopMessage -> Result
+;; [Listof world?] UniverseState world? StopMessage -> Result
 ;; world w sent message m when server is in state u 
 (define (switch u w m) ...)
 ])
 
 Although we could have re-used the generic contracts from this
 documentation, we also know from our protocol that our server sends a
-message to exactly one world. For this reason, both functions return the
-same kind of result: a bundle that contains the new state of the server
-(@tech{Universe}) and a list that contains a single mail. These contracts
-are just refinements of the generic ones. (A type-oriented programmer would
-say that the contracts here are subtypes of the generic ones.) 
+message to exactly one world. Note how these contracts are just refinements
+of the generic ones. (A type-oriented programmer would say that the
+contracts here are subtypes of the generic ones.)
 
 The second step of the design recipe calls for functional examples: 
 
@@ -1290,14 +1361,16 @@ The second step of the design recipe calls for functional examples:
 [schemeblock
 ;; an obvious example for adding a world: 
 (check-expect
-  (add-world '() world1) 
-  (make-bundle (list world1) 
+  (add-world '() '* world1) 
+  (make-bundle (list world1)
+               '*
                (list (make-mail world1 'it-is-your-turn))))
 
 ;; an example for receiving a message from the active world:
 (check-expect
- (switch (list world1 world2) world1 'it-is-your-turn)
+ (switch (list world1 world2) '* world1 'it-is-your-turn)
  (make-bundle (list world2 world1)
+              '*
               (list (make-mail world2 'it-is-your-turn))))
 ])
 
@@ -1310,23 +1383,24 @@ Exercise: Create additional examples for the two functions based on our
 protocol. 
 
 The protocol tells us that @emph{add-world} just adds the given
-@emph{world} structure---recall that this a data representation of the
-actual @tech{world} program---to the @tech{Universe} and then sends a
-message to the first world on this list to get things going:
+ @emph{world} structure---recall that this a data representation of the
+ actual @tech{world} program---to the given list of worlds. It then sends a
+ message to the first world on this list to get things going:
 
 @(begin
 #reader scribble/comment-reader
 [schemeblock
-(define (add-world univ wrld)
+(define (add-world univ state wrld)
   (local ((define univ* (append univ (list wrld))))
-    (make-bundle univ* 
+    (make-bundle univ*
+                 '*
                  (list (make-mail (first univ*) 'it-is-your-turn)))))
 ])
 
 Because @emph{univ*} contains at least @emph{wrld}, it is acceptable to
 create a mail to @scheme[(first univ*)]. Of course, this same reasoning
 also implies that if @emph{univ} isn't empty, its first element is an
-active world and has already received such a message. 
+active world and is about to receive a second @scheme['it-is-your-turn] message. 
 
 Similarly, the protocol says that when @emph{switch} is invoked because a
  @tech{world} program sends a message, the data representation of the
@@ -1336,14 +1410,16 @@ Similarly, the protocol says that when @emph{switch} is invoked because a
 @(begin
 #reader scribble/comment-reader
 [schemeblock
-(define (switch univ wrld m)
+(define (switch univ state wrld m)
   (local ((define univ* (append (rest univ) (list (first univ)))))
-    (make-bundle univ* (list (make-mail (first univ*) 'it-is-your-turn)))))
+    (make-bundle univ*
+                 '*
+                 (list (make-mail (first univ*) 'it-is-your-turn)))))
 ])
 
  As before, appending the first world to the end of the list guarantees
- that there is at least this one world on the next @tech{Universe}
- (state). It is therefore acceptable to create a mail for this world.
+ that there is at least this one world on this list. It is therefore
+ acceptable to create a mail for this world. 
 
 Exercise: The function definition simply assumes that @emph{wrld} is
  @scheme[world=?] to @scheme[(first univ)] and that the received message
@@ -1356,6 +1432,12 @@ Exercise: The function definition simply assumes that @emph{wrld} is
  depends on the context. For now, stop the @tech{universe} at this point,
  but consider alternative solutions, too.) 
 
+Exercise: An alternative state representation would equate 
+ @tech{UniverseState} with @emph{world} structures, keeping track of the
+ active world. The list of world in the server would track the passive
+ worlds only. Design appropriate @scheme[add-world] and @scheme[switch]
+ functions. 
+
 @; -----------------------------------------------------------------------------
 @subsection{Designing the Ball World}
 
@@ -1371,31 +1453,35 @@ The final step is to design the ball @tech{world}. Recall that each world
 (schemeblock 
 ;; teachpack: universe.ss
 
-;; World is one of 
+;; WorldState is one of:
 ;; -- Number	         %% representing the @emph{y} coordinate 
 ;; -- @scheme['resting]
 
 (define WORLD0 'resting)
+
+;; A WorldResult is one of:
+;; -- WorldState
+;; -- (make-package WorldState StopMessage)
 ))
  The definition says that initially a @tech{world} is passive. 
 
-The communication protocol and the refined data definition of @tech{World}
+The communication protocol and the refined data definition of @tech{WorldState}
  imply a number of contract and purpose statements: 
 
 @(begin
 #reader scribble/comment-reader
 (schemeblock
 
-;; World GoMessage -> World or (make-package World StopMessage)
+;; WorldState GoMessage -> WorldResult 
 ;; make sure the ball is moving 
 (define (receive w n) ...)
 
-;; World -> World or (make-package World StopMessage)
+;; WorldState -> WorldResult
 ;; move this ball upwards for each clock tick 
 ;; or stay @scheme['resting]
 (define (move w) ...) 
 
-;; World -> Scene
+;; WorldState -> Scene
 ;; render the world as a scene
 (define (render w) ...)
 ))
@@ -1403,7 +1489,7 @@ The communication protocol and the refined data definition of @tech{World}
 Let's design one function at a time, starting with @emph{receive}.  Since
  the protocol doesn't spell out what @emph{receive} is to compute, let's
  create a good set of functional examples, exploiting the structure of the
- data organization of @tech{World}:
+ data organization of @tech{WorldState}:
 
 @(begin
 #reader scribble/comment-reader
@@ -1458,7 +1544,7 @@ the scene every time @scheme['it-is-your-turn] is received. Design this function
 @(begin
 #reader scribble/comment-reader
 (schemeblock
-; World -> World or @scheme[(make-package 'resting 'done)]
+; WorldState -> WorldState or @scheme[(make-package 'resting 'done)]
 ; move the ball if it is flying
 
 (check-expect (move 'resting) 'resting)
@@ -1498,7 +1584,7 @@ Finally, here is the third function, which renders the state as a scene:
 @(begin
 #reader scribble/comment-reader
 (schemeblock
-; World -> Scene
+; WorldState -> Scene
 ; render the state of the world as a scene 
 
 (check-expect (render HEIGHT) (place-image BALL 50 HEIGHT MT))
@@ -1520,7 +1606,7 @@ Finally, here is the third function, which renders the state as a scene:
 @(begin
 #reader scribble/comment-reader
 (schemeblock
-; String -> (World -> Scene)
+; String -> (WorldState -> Scene)
 ; render the state of the world as a scene 
 
 (check-expect 
@@ -1545,7 +1631,7 @@ Finally, here is the third function, which renders the state as a scene:
 #reader scribble/comment-reader
 (schemeblock
 
-; String -> World 
+; String -> WorldState 
 ; create and hook up a world with the @scheme[LOCALHOST] server
 (define (create-world name)
   (big-bang WORLD0
diff --git a/collects/teachpack/2htdp/scribblings/balls.ss b/collects/teachpack/balls.ss
similarity index 100%
rename from collects/teachpack/2htdp/scribblings/balls.ss
rename to collects/teachpack/balls.ss
diff --git a/collects/teachpack/2htdp/scribblings/fsa.ss b/collects/teachpack/door.ss
similarity index 100%
rename from collects/teachpack/2htdp/scribblings/fsa.ss
rename to collects/teachpack/door.ss
diff --git a/collects/teachpack/2htdp/scribblings/nuworld.ss b/collects/teachpack/nuworld.ss
similarity index 98%
rename from collects/teachpack/2htdp/scribblings/nuworld.ss
rename to collects/teachpack/nuworld.ss
index 56a536a350..cbda2823b6 100644
--- a/collects/teachpack/2htdp/scribblings/nuworld.ss
+++ b/collects/teachpack/nuworld.ss
@@ -114,6 +114,6 @@
 
 (draw-pict the-image image-dc 0.0 0.0)
 
-(send image-bm save-file "nuworld.png" 'png)
+(send image-bm save-file "world.png" 'png)
 
 the-image
diff --git a/collects/teachpack/server.png b/collects/teachpack/server.png
new file mode 100644
index 0000000000..894bb07122
Binary files /dev/null and b/collects/teachpack/server.png differ
diff --git a/collects/teachpack/server.ss b/collects/teachpack/server.ss
new file mode 100644
index 0000000000..b8d3d790e4
--- /dev/null
+++ b/collects/teachpack/server.ss
@@ -0,0 +1,228 @@
+#lang slideshow
+
+(require slideshow/pict) 
+
+(define DELTA 80)
+(define FT 12)
+
+(define prgm 
+  '("(universe UniState_0"
+    "  (on-new register)"
+    "  (on-msg process)"
+    "  (on-dis disconnect)"
+    "  (on-tick tock)"
+    "  (to-string render))"))
+
+(define program 
+  (apply vl-append (map (lambda (t) (text t '() (- FT 2))) prgm)))
+
+(define Program 
+  (cc-superimpose 
+   (rectangle (+ 5 (pict-width program)) (+ 5 (pict-height program)))
+   program))
+
+(define (make-state txt)
+  (define t (text txt '() FT))
+  (define e (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t))))
+  (cc-superimpose t e))
+
+(define False (text "FALSE" '() FT))
+(define True  (text "TRUE"  '() FT))
+(define BOOL  (rectangle (+ 5 (pict-width False)) (+ 5 (pict-height False))))
+
+;; String Boolean -> Pict 
+(define (make-state0 txt b)
+  ;; create the basic state
+  (define t (text txt '() FT))
+  (define s (if b 
+                (cc-superimpose 
+                 (rounded-rectangle (+ 5 (pict-width t))  (+ (- DELTA 5) (pict-height t)))
+                 t)
+                t))
+  (define w 
+    (cc-superimpose 
+     s
+     (rounded-rectangle (+ 10 (pict-width t)) (+ DELTA (pict-height t)))))
+  ;; add the boolean 
+  (define bb (cc-superimpose (if b True False) BOOL))
+  (define ar0 (add-labeled-arrow (vc-append DELTA bb w) w ct-find bb cb-find "done"))
+  ;; HIDE the arrow and done
+  (define ar (cb-superimpose w (blank (pict-width ar0) (pict-height ar0))))
+  (define scene (text "string" '() FT))
+  (define sc (cc-superimpose scene (rectangle (+ 20 (pict-width scene)) (+ 30 (pict-height scene)))))
+  (define br (add-labeled-arrow (vc-append DELTA ar sc) ar cb-find sc ct-find "render"))
+  br)
+
+(define (add-labeled-arrow nx locked lb-find closed lt-find txt)
+  (define-values (x0 y0) (lb-find nx locked))
+  (define-values (x1 y1) (lt-find nx closed))
+  (define lbl (text txt '() (- FT 2)))
+  (define wlbl (pict-width lbl))
+  (define hlbl (pict-height lbl))
+  (define x (- x0 (/ wlbl 2)))
+  (define y (+ y0 (/ ( - y1 y0 hlbl) 2)))
+  (pin-over (pin-arrow-line 4.0 nx locked lb-find closed lt-find) x y lbl))
+
+(define (h-labeled-arrow t)
+  (define tock (text t '() (- FT 2)))
+  (define blk (blank (+ DELTA 4) 2))
+  (vc-append tock (pin-arrow-line 4.0 blk blk lc-find blk rc-find)))
+
+(define message (text "Message" '() FT))
+(define (make-Message)
+  (cc-superimpose message (rectangle (+ 20 (pict-width message)) (+ 30 (pict-height message)))))
+
+(define Message  (vc-append (make-Message) (arrowhead 4 (* 1/2 pi))))
+(define MessageK (vc-append (arrowhead 4 (* 3/2 pi)) (make-Message)))
+
+(define M (rb-superimpose Message (blank DELTA  DELTA))) 
+(define K (rb-superimpose MessageK (blank DELTA  DELTA)))
+
+(define (make-arrows M)
+  (define Tock (h-labeled-arrow "register"))
+  (define Click (h-labeled-arrow "tock"))
+  (define Clack (h-labeled-arrow "disconnect"))
+  (define Receive (h-labeled-arrow "process"))
+  (values Tock Click Clack Receive (vc-append (blank DELTA (/ DELTA 2)) Tock Click Clack Receive M)))
+
+(define-values (TockM ClickM ClackM ReceiveM arrowsR) (make-arrows M))
+(define-values (TockK ClickK ClackK ReceiveK arrowsL) (make-arrows K))
+
+(define state0 (make-state0 "UniState_0" #f))
+(define state1 (make-state0 "UniState_1" #f))
+(define Server (hc-append (arrowhead 4 0) (cc-superimpose (cloud 160 80) (text "UNIVERSE" '() FT ))))
+(define world  (cc-superimpose (cloud 80 40) (text "world" '() FT )))
+(define dots   (vc-append
+                (cc-superimpose (blank (pict-width state1) (pict-height state1)) (text "..." '() FT))
+                world
+                Server))
+(define state2 (make-state0 "UniState_N-1" #f))
+(define stateN (make-state0 "UniState_N" #t))
+(define states (list state1 arrowsL dots arrowsR state2))
+
+(define bg (blank (+ (apply + (map pict-width states)) DELTA)
+                  (+ (pict-height state0) DELTA)))
+
+(define (center base state x)
+  (define w (pict-height state))
+  (define d (quotient (- width w) 2))
+  (pin-over base x d state))
+
+(define width (pict-height bg))
+
+(define x (* 1/2 DELTA))
+(define xx 
+  (foldl (lambda (f ls s)
+           (define y (center s f x))
+           (set! x (+ x ls))
+           y)
+         bg
+         states
+         (map (lambda (x) (+ (pict-width x) #;(* 1/1 DELTA))) states)))
+
+(define zz xx)
+
+(require mred/mred)
+
+(define the-image
+  (ct-superimpose Program
+                  (lt-superimpose 
+                   (dc (lambda (dc x y)
+                         (define-values (mx my) (cb-find zz MessageK))
+                         (define-values (tx ty) (ct-find zz MessageK))
+                         (define-values (sx sy) (lc-find zz Server))
+                         (define-values (tockx tocky) (lb-find zz TockK))
+                         (define-values (clickx clicky) (lb-find zz ClickK))
+                         (define-values (clackx clacky) (lb-find zz ClackK))
+                         (define-values (rx ry) (lb-find zz ReceiveK))
+                         (define (add-curve rx ry)
+                           (set! dcp (make-object dc-path%))
+                           (set! cx (max rx tx))
+                           (set! cy (min ry ty))
+                           (send dcp move-to tx ty)
+                           (send dcp curve-to tx ty cx cy rx ry)
+                           (send dc draw-path dcp))
+                         (define dcp (make-object dc-path%))
+                         ;; --- draw arc from Message to Server 
+                         (define cx (min sx mx))
+                         (define cy (max sy my))
+                         (send dc set-smoothing 'aligned)
+                         (send dcp move-to mx my)
+                         (send dcp curve-to mx my cx cy sx sy)
+                         (send dc draw-path dcp)
+                         ;; --- draw arc from Message to Receiver 
+                         (add-curve tockx tocky)
+                         (add-curve clickx clicky)
+                         (add-curve clackx clacky)
+                         (add-curve rx ry)
+                         ;; --- 
+                         dc)
+                       (pict-width zz) (pict-height zz))
+                   (lt-superimpose
+                    (lt-superimpose
+                     zz
+                     (dc (lambda (dc x y)
+                           (define-values (mx my) (cb-find zz world))
+                           (define-values (tx ty) (ct-find zz world))
+                           (define-values (sx sy) (rc-find zz Server))
+                           (define-values (rx ry) (rb-find zz ReceiveM))
+                           (define dcp (make-object dc-path%))
+                           ;; --- draw arc from Message to Server 
+                           (define cx (max sx mx))
+                           (define cy (max sy my))
+#|                           
+                           (send dc set-smoothing 'aligned)
+                           (send dcp move-to mx my)
+                           (send dcp curve-to mx my cx cy sx sy)
+                           (send dc draw-path dcp)
+|#
+                           ;; --- draw arc from Message to Receiver 
+                           (set! dcp (make-object dc-path%))
+                           (set! cx (min rx tx))
+                           (set! cy (min ry ty))
+                           (send dcp move-to tx ty)
+                           (send dcp curve-to tx ty cx cy rx ry)
+                           (send dc draw-path dcp)
+                           ;; --- 
+                           dc)
+                         (pict-width zz) (pict-height zz)))
+                    (dc (lambda (dc x y)
+                          (define-values (mx my) (cb-find zz Message))
+                          (define-values (tx ty) (ct-find zz Message))
+                          (define-values (sx sy) (rc-find zz Server))
+                          (define-values (rx ry) (rb-find zz ReceiveM))
+                          (define dcp (make-object dc-path%))
+                          ;; --- draw arc from Message to Server 
+                          (define cx (max sx mx))
+                          (define cy (max sy my))
+                          (send dc set-smoothing 'aligned)
+                          (send dcp move-to mx my)
+                          (send dcp curve-to mx my cx cy sx sy)
+                          (send dc draw-path dcp)
+                          ;; --- draw arc from Message to Receiver 
+                          (set! dcp (make-object dc-path%))
+                          (set! cx (min rx tx))
+                          (set! cy (min ry ty))
+                          (send dcp move-to tx ty)
+                          (send dcp curve-to tx ty cx cy rx ry)
+                          (send dc draw-path dcp)
+                          ;; --- 
+                          dc)
+                        (pict-width zz) (pict-height zz))))))
+
+(define image-bm
+  (make-object bitmap% 
+    (inexact->exact (round (pict-width the-image)))
+    (inexact->exact (round (pict-height the-image)))))
+
+(send image-bm ok?)
+
+(define image-dc
+  (new bitmap-dc% [bitmap image-bm]))
+(send image-dc clear)
+
+(draw-pict the-image image-dc 0.0 0.0)
+
+(send image-bm save-file "server.png" 'png)
+
+the-image
diff --git a/collects/teachpack/server2.png b/collects/teachpack/server2.png
deleted file mode 100644
index 99f02cea21..0000000000
Binary files a/collects/teachpack/server2.png and /dev/null differ
diff --git a/collects/teachpack/universe.png b/collects/teachpack/universe.png
deleted file mode 100644
index 81cb2ef2db..0000000000
Binary files a/collects/teachpack/universe.png and /dev/null differ
diff --git a/collects/teachpack/universe2.png b/collects/teachpack/universe2.png
deleted file mode 100644
index 8757563664..0000000000
Binary files a/collects/teachpack/universe2.png and /dev/null differ
diff --git a/collects/teachpack/world.png b/collects/teachpack/world.png
index 82dd678265..2b215663af 100644
Binary files a/collects/teachpack/world.png and b/collects/teachpack/world.png differ
diff --git a/collects/teachpack/2htdp/scribblings/universe.ss b/collects/teachpack/world.ss
similarity index 100%
rename from collects/teachpack/2htdp/scribblings/universe.ss
rename to collects/teachpack/world.ss
diff --git a/collects/tests/mzscheme/mzlib-tests.ss b/collects/tests/mzscheme/mzlib-tests.ss
index 6003409b7e..6e89d5435f 100644
--- a/collects/tests/mzscheme/mzlib-tests.ss
+++ b/collects/tests/mzscheme/mzlib-tests.ss
@@ -10,6 +10,7 @@
 (load-in-sandbox "async-channel.ss")
 (load-in-sandbox "restart.ss")
 (load-in-sandbox "string-mzlib.ss")
+(load-in-sandbox "pathlib.ss")
 (load-in-sandbox "filelib.ss")
 (load-in-sandbox "portlib.ss")
 (load-in-sandbox "threadlib.ss")
diff --git a/collects/tests/mzscheme/pathlib.ss b/collects/tests/mzscheme/pathlib.ss
new file mode 100644
index 0000000000..a1f53be883
--- /dev/null
+++ b/collects/tests/mzscheme/pathlib.ss
@@ -0,0 +1,79 @@
+
+(load-relative "loadtest.ss")
+
+(Section 'path)
+
+(require scheme/path)
+
+(define (rtest f args result)
+  (test result f args))
+
+;; ----------------------------------------
+
+(rtest explode-path "a/b" (list (string->path "a")
+                                (string->path "b")))
+(rtest explode-path "a/../b" (list (string->path "a")
+                                   'up
+                                   (string->path "b")))
+(rtest explode-path "./a/b" (list 'same
+                                  (string->path "a")
+                                  (string->path "b")))
+(rtest explode-path (bytes->path #"./a/b" 'unix) (list 'same
+                                                       (bytes->path #"a" 'unix)
+                                                       (bytes->path #"b" 'unix)))
+(rtest explode-path (bytes->path #"./a\\b" 'windows) (list 'same
+                                                           (bytes->path #"a" 'windows)
+                                                           (bytes->path #"b" 'windows)))
+
+;; ----------------------------------------
+
+(rtest file-name-from-path "a/" #f)
+(rtest file-name-from-path "a/b" (string->path "b"))
+(rtest file-name-from-path (bytes->path #"a/b" 'unix) (bytes->path #"b" 'unix))
+(rtest file-name-from-path (bytes->path #"a\\b" 'windows) (bytes->path #"b" 'windows))
+
+;; ----------------------------------------
+
+(rtest filename-extension "a" #f)
+(rtest filename-extension "a.sls" #"sls")
+(rtest filename-extension (bytes->path #"b/a.sls" 'unix) #"sls")
+(rtest filename-extension (bytes->path #"b\\a.sls" 'windows) #"sls")
+
+;; ----------------------------------------
+
+(test (string->path "a") find-relative-path (path->complete-path "b") (path->complete-path "b/a"))
+(test (string->path "../../b/a") find-relative-path (path->complete-path "c/b") (path->complete-path "b/a"))
+(test (bytes->path #"a" 'unix) find-relative-path (bytes->path #"/r/b" 'unix) (bytes->path #"/r/b/a" 'unix))
+(test (bytes->path #"a" 'windows) find-relative-path (bytes->path #"c:/r/b" 'windows) (bytes->path #"c:/r/b/a" 'windows))
+
+;; ----------------------------------------
+
+;; normalize-path needs tests
+
+;; ----------------------------------------
+
+(rtest path-only "a/b" (string->path "a/"))
+(rtest path-only "a/b/" (string->path "a/b/"))
+(rtest path-only "a/.." (string->path "a/.."))
+(rtest path-only (bytes->path #"a/z" 'unix) (bytes->path #"a/" 'unix))
+(rtest path-only (bytes->path #"a/z/" 'unix) (bytes->path #"a/z/" 'unix))
+(rtest path-only (bytes->path #"a/z" 'windows) (bytes->path #"a/" 'windows))
+(rtest path-only (bytes->path #"a/z/" 'windows) (bytes->path #"a/z/" 'windows))
+
+;; ----------------------------------------
+
+;; simple-form-path needs tests
+
+;; ----------------------------------------
+
+(test "a" some-system-path->string (string->path "a"))
+(test "a" some-system-path->string (bytes->path #"a" 'unix))
+(test "a" some-system-path->string (bytes->path #"a" 'windows))
+(test #t path-for-some-system? (string->some-system-path "a" 'unix))
+(test #t path-for-some-system? (string->some-system-path "a" 'windows))
+(test "a" some-system-path->string (string->some-system-path "a" 'unix))
+(test "a" some-system-path->string (string->some-system-path "a" 'windows))
+
+;; ----------------------------------------
+
+(report-errs)
diff --git a/collects/web-server/dispatchers/limit.ss b/collects/web-server/dispatchers/limit.ss
new file mode 100644
index 0000000000..8cfe48cc6e
--- /dev/null
+++ b/collects/web-server/dispatchers/limit.ss
@@ -0,0 +1,46 @@
+#lang scheme
+(require "dispatch.ss")
+(provide/contract
+ [interface-version dispatcher-interface-version/c]
+ [make (number? dispatcher/c . -> . dispatcher/c)])
+
+(define interface-version 'v1)
+(define (make num inner)
+  (define-struct in-req (partner reply-ch))
+  (define in-ch (make-channel))
+  (define-struct out-req (partner))
+  (define out-ch (make-channel))
+  (define limit-manager
+    (thread
+     (lambda ()
+       (let loop ([i 0]
+                  [partners empty])
+         (apply sync 
+                (if (< i num)
+                    (handle-evt in-ch
+                                (lambda (req)
+                                  (channel-put (in-req-reply-ch req) #t)
+                                  (loop (add1 i)
+                                        (list* (in-req-partner req) partners))))
+                    never-evt)
+                (handle-evt out-ch
+                            (lambda (req)
+                              (loop (sub1 i)
+                                    (remq (out-req-partner req) partners))))
+                (map (lambda (p)
+                       (handle-evt (thread-dead-evt p)
+                                   (lambda _
+                                     (loop (sub1 i) (remq p partners)))))
+                     partners))))))
+  (define (in)
+    (define reply (make-channel))
+    (channel-put in-ch (make-in-req (current-thread) reply))
+    (channel-get reply))
+  (define (out)
+    (channel-put out-ch (make-out-req (current-thread))))
+  (lambda (conn req)
+    (dynamic-wind 
+     in
+     (lambda () 
+       (inner conn req))
+     out)))
diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl
index 1622cee48c..efb98175fb 100644
--- a/collects/web-server/scribblings/dispatchers.scrbl
+++ b/collects/web-server/scribblings/dispatchers.scrbl
@@ -388,3 +388,62 @@ a URL that refreshes the password file, servlet cache, etc.}
          dispatcher/c]{
  Returns a dispatcher that prints memory usage on every request.
 }}
+
+@; ------------------------------------------------------------
+@section[#:tag "limit.ss"]{Limiting Requests}
+@a-dispatcher[web-server/dispatchers/limit
+              @elem{provides a wrapper dispatcher that limits how many requests are serviced at once.}]{
+
+@defproc[(make [limit number?]
+               [inner dispatcher/c])
+         dispatcher/c]{
+ Returns a dispatcher that defers to @scheme[inner] for work, but will forward a maximum of @scheme[limit] requests concurrently.
+}}
+                      
+@(require (for-label
+           web-server/web-server
+           web-server/http
+           (prefix-in limit: web-server/dispatchers/limit)
+           (prefix-in filter: web-server/dispatchers/dispatch-filter)
+           (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)))
+                                                                                                       
+Consider this example:
+@schememod[
+ scheme
+ 
+(require web-server/web-server
+         web-server/http
+         web-server/http/response
+         (prefix-in limit: web-server/dispatchers/limit)
+         (prefix-in filter: web-server/dispatchers/dispatch-filter)
+         (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer))
+
+(serve #:dispatch
+       (sequencer:make
+        (filter:make
+         #rx"/limited"
+         (limit:make
+          5
+          (lambda (conn req)
+            (output-response/method
+             conn
+             (make-response/full
+              200 "Okay"
+              (current-seconds) TEXT/HTML-MIME-TYPE
+              empty
+              (list (format "hello world ~a"
+                            (sort (build-list 100000 (λ x (random 1000)))
+                                  <))))
+             (request-method req)))))
+        (lambda (conn req)          
+          (output-response/method
+           conn
+           (make-response/full 200 "Okay"
+                               (current-seconds) TEXT/HTML-MIME-TYPE
+                               empty
+                               (list "<html><body>Unlimited</body></html>"))
+           (request-method req))))
+       #:port 8080)
+
+(do-not-return)
+]
diff --git a/collects/web-server/scribblings/faq.scrbl b/collects/web-server/scribblings/faq.scrbl
index 1c1c31d6ca..cb9fc203d5 100644
--- a/collects/web-server/scribblings/faq.scrbl
+++ b/collects/web-server/scribblings/faq.scrbl
@@ -104,18 +104,4 @@ The Web Server will start on port 443 (which can be overridden with the @exec{-p
 
 @section{How do I limit the number of requests serviced at once by the Web Server?}
 
-There is no built-in option for this, but you can easily accomplish it if you assemble your own dispatcher
-by wrapping it in @scheme[call-with-semaphore]:
-@schemeblock[
-(define (make-limit-dispatcher num inner)
- (let ([sem (make-semaphore num)])
-   (lambda (conn req)
-     (call-with-semaphore sem
-       (lambda () (inner conn req))))))
-]
-
-Once this function is available, rather than providing @scheme[james-gordon] as your dispatcher, you provide:
-@scheme[(make-limit-dispatch 50 james-gordon)] (if you only want 50 concurrent requests.) One interesting
-application of this pattern is to have a limit on certain kinds of requests. For example, you could have a
-limit of 50 servlet requests, but no limit on filesystem requests.
-
+Refer to @secref["limit.ss"].
diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt
index ebfcfd7801..28df148eb8 100644
--- a/doc/release-notes/mzscheme/HISTORY.txt
+++ b/doc/release-notes/mzscheme/HISTORY.txt
@@ -1,6 +1,5 @@
-Somewhere in there:
- function contracts now preserve tail recursion in many cases; the
- 'any' contract is no longer special.
+Version 4.1.3.10
+Added syntax-local-lift-require
 
 Version 4.1.3.8
 Added procedure-rename
@@ -15,6 +14,7 @@ Version 4.1.3.6
 Memory accounting changed to bias charges to parent instead of children
 
 Version 4.1.3.3
+Function contracts preserve tail recursion in many cases
 Added compile-context-preservation-enabled
 Added exception-backtrace support for x86_84+JIT
 Added scheme/package, scheme/splicing
diff --git a/src/mred/wxme/wx_mline.cxx b/src/mred/wxme/wx_mline.cxx
index afaa853190..60b7ac05cf 100644
--- a/src/mred/wxme/wx_mline.cxx
+++ b/src/mred/wxme/wx_mline.cxx
@@ -321,7 +321,7 @@ void wxMediaLine::Delete(wxMediaLine **root)
   else
     x = v->right;
 
-  x->parent = v->parent;
+  x->parent = v->parent; /* x could be NIL; fixup at end */
 
   if (PTREQ(v->parent, NIL))
     *root = x;
@@ -448,6 +448,11 @@ void wxMediaLine::Delete(wxMediaLine **root)
     SET_BLACK(x);
   }
 
+  if (PTRNE(NIL->parent, NIL)) {
+    /* fixup: we set NIL's parent above */
+    NIL->parent = NIL;
+  }
+
   right = left = NIL;
   DELETE_OBJ this;
 }
@@ -594,7 +599,8 @@ wxMediaParagraph *wxMediaLine::GetParagraphStyle(Bool *first)
     } else {                                 \
       node = node->parent;                   \
     }                                        \
-  }                                          \
+  }
+
 
 void wxMediaLine::SetLength(long len)
 {
diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c
index 2cd890ec5c..90aff15d8e 100644
--- a/src/mzscheme/src/env.c
+++ b/src/mzscheme/src/env.c
@@ -110,6 +110,7 @@ static Scheme_Object *local_module_expanding_provides(int argc, Scheme_Object *a
 static Scheme_Object *local_lift_expr(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_lift_context(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_lift_end_statement(int argc, Scheme_Object *argv[]);
+static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]);
 static Scheme_Object *make_introducer(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[]);
 static Scheme_Object *make_set_transformer(int argc, Scheme_Object *argv[]);
@@ -550,6 +551,7 @@ static void make_kernel_env(void)
   GLOBAL_PRIM_W_ARITY("syntax-local-lift-expression", local_lift_expr, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-lift-context", local_lift_context, 0, 0, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-lift-module-end-declaration", local_lift_end_statement, 1, 1, env);
+  GLOBAL_PRIM_W_ARITY("syntax-local-lift-require", local_lift_require, 2, 2, env);
 
   {
     Scheme_Object *sym;
@@ -1366,7 +1368,7 @@ scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *f
 }
 
 void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, 
-                                 Scheme_Object *end_stmts, Scheme_Object *context_key)
+                                 Scheme_Object *end_stmts, Scheme_Object *context_key, Scheme_Object *requires)
 {
   Scheme_Lift_Capture_Proc *pp;
   Scheme_Object *vec;
@@ -1374,16 +1376,45 @@ void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc
   pp = (Scheme_Lift_Capture_Proc *)scheme_malloc_atomic(sizeof(Scheme_Lift_Capture_Proc));
   *pp = cp;
 
-  vec = scheme_make_vector(5, NULL);
+  vec = scheme_make_vector(7, NULL);
   SCHEME_VEC_ELS(vec)[0] = scheme_null;
   SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp;
   SCHEME_VEC_ELS(vec)[2] = data;
   SCHEME_VEC_ELS(vec)[3] = end_stmts;
   SCHEME_VEC_ELS(vec)[4] = context_key;
+  SCHEME_VEC_ELS(vec)[5] = (requires ? requires : scheme_false);
+  SCHEME_VEC_ELS(vec)[6] = scheme_null; /* accumulated requires */
 
   COMPILE_DATA(env)->lifts = vec;
 }
 
+void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env)
+{
+  while (orig_env) {
+    if ((COMPILE_DATA(orig_env)->lifts)
+        && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(orig_env)->lifts)[5]))
+      break;
+    orig_env = orig_env->next;
+  }
+  
+  if (orig_env) {
+    Scheme_Object *vec, *p;
+
+    p = scheme_make_raw_pair(NULL, (Scheme_Object *)orig_env);
+
+    vec = scheme_make_vector(7, NULL);
+    SCHEME_VEC_ELS(vec)[0] = scheme_false;
+    SCHEME_VEC_ELS(vec)[1] = scheme_void;
+    SCHEME_VEC_ELS(vec)[2] = scheme_void;
+    SCHEME_VEC_ELS(vec)[3] = scheme_false;
+    SCHEME_VEC_ELS(vec)[4] = scheme_false;
+    SCHEME_VEC_ELS(vec)[5] = p; /* (rcons NULL env) => continue with env */
+    SCHEME_VEC_ELS(vec)[6] = scheme_null;
+
+    COMPILE_DATA(env)->lifts = vec;
+  }
+}
+
 Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env)
 {
   return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0];
@@ -1394,6 +1425,11 @@ Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env)
   return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3];
 }
 
+Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env)
+{
+  return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6];
+}
+
 void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env)
 {
   Scheme_Object **ns, **vs;
@@ -4748,6 +4784,10 @@ local_lift_expr(int argc, Scheme_Object *argv[])
     env = env->next;
   }
 
+  if (env)
+    if (SCHEME_FALSEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0]))
+      env = NULL;
+
   if (!env)
     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
 		     "syntax-local-lift-expression: no lift target");
@@ -4851,6 +4891,61 @@ local_lift_end_statement(int argc, Scheme_Object *argv[])
   return scheme_void;
 }
 
+static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[])
+{
+  Scheme_Comp_Env *env;
+  Scheme_Object *local_mark, *mark, *data, *pr, *form;
+  long phase;
+
+  if (!SCHEME_STXP(argv[1]))
+    scheme_wrong_type("syntax-local-lift-require", "syntax", 1, argc, argv);
+
+  env = scheme_current_thread->current_local_env;
+  local_mark = scheme_current_thread->current_local_mark;
+  phase = env->genv->phase;
+
+  if (!env)
+    scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
+		     "syntax-local-lift-require: not currently transforming");
+
+  data = NULL;
+
+  while (env) {
+    if (COMPILE_DATA(env)->lifts
+        && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[5])) {
+      data = SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[5];
+      if (SCHEME_RPAIRP(data)
+          && !SCHEME_CAR(data)) {
+        env = (Scheme_Comp_Env *)SCHEME_CDR(data);
+      } else
+        break;
+    } else
+      env = env->next;
+  }
+
+  if (!env)
+    scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
+		     "syntax-local-lift-requires: could not find target context");
+
+  
+  mark = scheme_new_mark();
+
+  if (SCHEME_RPAIRP(data))
+    form = scheme_parse_lifted_require(argv[0], phase, mark, SCHEME_CAR(data));
+  else
+    form = scheme_toplevel_require_for_expand(argv[0], phase, env, mark);
+  
+  pr = scheme_make_pair(form, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6]);
+  SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6] = pr;
+
+  form = argv[1];
+  form = scheme_add_remove_mark(form, local_mark);
+  form = scheme_add_remove_mark(form, mark);
+  form = scheme_add_remove_mark(form, local_mark);
+
+  return form;
+}
+
 static Scheme_Object *
 make_set_transformer(int argc, Scheme_Object *argv[])
 {
diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c
index 8237049fba..446d809fe4 100644
--- a/src/mzscheme/src/error.c
+++ b/src/mzscheme/src/error.c
@@ -1217,6 +1217,10 @@ char *scheme_make_arity_expect_string(Scheme_Object *proc,
     }
     name = scheme_get_proc_name((Scheme_Object *)proc, &namelen, 1);
 #endif
+  } else if (SCHEME_STRUCTP(proc)) {
+    name = (const char *)proc;
+    mina = -1;
+    maxa = 0;
   } else {
     Scheme_Closure_Data *data;
 
diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c
index e93bcc8f90..17d1ae7b7b 100644
--- a/src/mzscheme/src/eval.c
+++ b/src/mzscheme/src/eval.c
@@ -4911,7 +4911,7 @@ static void *compile_k(void)
   int writeable, for_eval, rename, enforce_consts, comp_flags;
   Scheme_Env *genv;
   Scheme_Compile_Info rec, rec2;
-  Scheme_Object *o, *tl_queue;
+  Scheme_Object *o, *rl, *tl_queue;
   Scheme_Compilation_Top *top;
   Resolve_Prefix *rp;
   Resolve_Info *ri;
@@ -4973,7 +4973,8 @@ static void *compile_k(void)
 	 find one, break it up to eval first expression
 	 before the rest. */
       while (1) {
-	scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false, scheme_false);
+	scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), 
+                                    scheme_false, scheme_false, scheme_null);
 	form = scheme_check_immediate_macro(form, 
 					    cenv, &rec, 0,
 					    0, &gval, NULL, NULL);
@@ -4989,10 +4990,13 @@ static void *compile_k(void)
 	  } else
 	    break;
 	} else {
+	  rl = scheme_frame_get_require_lifts(cenv);
 	  o = scheme_frame_get_lifts(cenv);
-	  if (!SCHEME_NULLP(o)) {
+	  if (!SCHEME_NULLP(o)
+              || !SCHEME_NULLP(rl)) {
 	    tl_queue = scheme_make_pair(form, tl_queue);
 	    tl_queue = scheme_append(o, tl_queue);
+	    tl_queue = scheme_append(rl, tl_queue);
 	    form = SCHEME_CAR(tl_queue);
 	    tl_queue = SCHEME_CDR(tl_queue);
 	  }
@@ -5010,7 +5014,8 @@ static void *compile_k(void)
       Scheme_Object *l, *prev_o = NULL;
 
       while (1) {
-	scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false, scheme_false);
+	scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), 
+                                    scheme_false, scheme_false, scheme_null);
 
 	scheme_init_compile_recs(&rec, 0, &rec2, 1);
 
@@ -5031,10 +5036,13 @@ static void *compile_k(void)
 	/* If any definitions were lifted in the process of compiling o,
 	   we need to fold them in. */
 	l = scheme_frame_get_lifts(cenv);
-	if (!SCHEME_NULLP(l)) {
-	  l = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(cenv), 0, 0),
-		    l);
-	  form = scheme_datum_to_syntax(l, scheme_false, scheme_false, 0, 0);
+	rl = scheme_frame_get_require_lifts(cenv);
+	if (!SCHEME_NULLP(l)
+            || !SCHEME_NULLP(rl)) {
+          rl = scheme_append(rl, l);
+          rl = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(cenv), 0, 0),
+                     rl);
+          form = scheme_datum_to_syntax(rl, scheme_false, scheme_false, 0, 0);
 	  prev_o = o;
 	} else 
 	  break;
@@ -6213,7 +6221,7 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
 
   context_key = scheme_generate_lifts_key();
   
-  scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false, context_key);
+  scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false, context_key, NULL);
 
   if (rec[drec].comp) {
     scheme_init_compile_recs(rec, drec, recs, 2);
@@ -8877,7 +8885,9 @@ static void *expand_k(void)
     erec1.comp_flags = comp_flags;
 
     if (catch_lifts_key)
-      scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, catch_lifts_key);
+      scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), 
+                                  scheme_false, catch_lifts_key, 
+                                  (!as_local && catch_lifts_key) ? scheme_null : NULL);
   
     if (just_to_top) {
       Scheme_Object *gval;
@@ -8886,9 +8896,12 @@ static void *expand_k(void)
       obj = scheme_expand_expr(obj, env, &erec1, 0);
 
     if (catch_lifts_key) {
-      Scheme_Object *l;
+      Scheme_Object *l, *rl;
       l = scheme_frame_get_lifts(env);
-      if (SCHEME_PAIRP(l)) {
+      rl = scheme_frame_get_require_lifts(env);
+      if (SCHEME_PAIRP(l)
+          || SCHEME_PAIRP(rl)) {
+        l = scheme_append(rl, l);
         obj = add_lifts_as_begin(obj, l, env);
         SCHEME_EXPAND_OBSERVE_LIFT_LOOP(erec1.observer,obj);
 	if ((depth >= 0) || as_local)
@@ -9189,6 +9202,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
   if (for_stx) {
     scheme_prepare_exp_env(env->genv);
     env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);
+    scheme_propagate_require_lift_capture(orig_env, env);
   }
 
   if (for_expr)
@@ -9322,7 +9336,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
 
     if (catch_lifts_key)
       scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, 
-                                  catch_lifts_key);
+                                  catch_lifts_key, NULL);
 
     memset(drec, 0, sizeof(drec));
     drec[0].value_name = scheme_false; /* or scheme_current_thread->current_local_name ? */
diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c
index 98efadf023..2398ea2ba4 100644
--- a/src/mzscheme/src/module.c
+++ b/src/mzscheme/src/module.c
@@ -5749,6 +5749,76 @@ static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_id,
   return scheme_make_lifted_defn(scheme_sys_wraps(env), _id, expr, _env);
 }
 
+static Scheme_Object *make_require_form(Scheme_Object *module_path, long phase, Scheme_Object *mark)
+{
+  Scheme_Object *e = module_path;
+
+  if (phase != 0) {
+    e = scheme_make_pair(for_meta_symbol,
+                         scheme_make_pair(scheme_make_integer(phase),
+                                          scheme_make_pair(e,
+                                                           scheme_null)));
+  }
+  e = scheme_make_pair(require_stx, scheme_make_pair(e, scheme_null));
+  e = scheme_datum_to_syntax(e, scheme_false, scheme_false, 0, 0);
+
+  e = scheme_add_remove_mark(e, mark);
+
+  return e;
+}
+
+Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path,
+                                           long phase,
+                                           Scheme_Object *mark,
+                                           void *data)
+{
+  Scheme_Object *e;
+  Scheme_Object *base_modidx = (Scheme_Object *)((void **)data)[1];
+  Scheme_Env *env = (Scheme_Env *)((void **)data)[2];
+  Scheme_Module *for_m = (Scheme_Module *)((void **)data)[3];
+  Scheme_Object *rns = (Scheme_Object *)((void **)data)[4];
+  Scheme_Object *post_ex_rns = (Scheme_Object *)((void **)data)[5];
+  void *tables = ((void **)data)[6];
+  Scheme_Object *redef_modname = (Scheme_Object *)((void **)data)[7];
+  int *all_simple = (int *)((void **)data)[8];
+
+  e = make_require_form(module_path, phase, mark);
+
+  parse_requires(e, base_modidx, env, for_m,
+                 rns, post_ex_rns,
+                 check_require_name, tables,
+                 redef_modname, 
+                 0, 0, 1, 0,
+                 all_simple);
+
+  return e;
+}
+
+static Scheme_Object *package_require_data(Scheme_Object *base_modidx,
+                                           Scheme_Env *env,
+                                           Scheme_Module *for_m,
+                                           Scheme_Object *rns, Scheme_Object *post_ex_rns,
+                                           void *data,
+                                           Scheme_Object *redef_modname,
+                                           int *all_simple)
+{
+  void **vals;
+
+  vals = MALLOC_N(void*, 9);
+  vals[0] = NULL; /* this slot is available */
+  vals[1] = base_modidx;
+  vals[2] = env;
+  vals[3] = for_m;
+  vals[4] = rns;
+  vals[5] = post_ex_rns;
+  vals[6] = data;
+  vals[7] = redef_modname;
+  vals[8] = all_simple;
+
+  return scheme_make_raw_pair((Scheme_Object *)vals, NULL);
+}
+
+
 static void flush_definitions(Scheme_Env *genv)
 {
   if (genv->syntax) {
@@ -5786,9 +5856,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
   Scheme_Object *exclude_hint = scheme_false, *lift_data;
   Scheme_Object **exis, **et_exis, **exsis;
   Scheme_Object *lift_ctx;
+  Scheme_Object *lifted_reqs = scheme_null, *req_data;
   int exicount, et_exicount, exsicount;
   char *exps, *et_exps;
-  int all_simple_renames = 1;
+  int *all_simple_renames;
   int maybe_has_lifts = 0;
   int reprovide_kernel;
   Scheme_Object *redef_modname;
@@ -5931,6 +6002,15 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
   maybe_has_lifts = 0;
   lift_ctx = scheme_generate_lifts_key();
 
+  all_simple_renames = (int *)scheme_malloc_atomic(sizeof(int));
+  *all_simple_renames = 1;
+
+  req_data = package_require_data(self_modidx, env->genv, env->genv->module,
+                                  rn_set, post_ex_rn_set,
+                                  tables,
+                                  redef_modname, 
+                                  all_simple_renames);
+
   /* Pass 1 */
 
   /* Partially expand all expressions, and process definitions, requires,
@@ -5949,7 +6029,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
       p = (maybe_has_lifts 
            ? scheme_frame_get_end_statement_lifts(xenv) 
            : scheme_null);
-      scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), p, lift_ctx);
+      scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), 
+                                  p, lift_ctx, req_data);
       maybe_has_lifts = 1;
 
       {
@@ -5966,11 +6047,13 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	e = scheme_expand_expr(e, xenv, &erec1, 0);	
       }
 
+      lifted_reqs = scheme_append(scheme_frame_get_require_lifts(xenv), lifted_reqs);
+
       fst = scheme_frame_get_lifts(xenv);
       if (!SCHEME_NULLP(fst)) {
 	/* Expansion lifted expressions, so add them to
 	   the front and try again. */
-        all_simple_renames = 0;
+        *all_simple_renames = 0;
 	fm = SCHEME_STX_CDR(fm);
         e = scheme_add_rename(e, post_ex_rn_set);
         fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_rn_set);
@@ -6066,7 +6149,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	    /* Add a renaming: */
 	    if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) {
 	      scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0);
-              all_simple_renames = 0;
+              *all_simple_renames = 0;
 	    } else
 	      scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0);
 
@@ -6102,6 +6185,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	  
 	  scheme_prepare_exp_env(env->genv);
 	  eenv = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);
+          scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false, req_data);
 
 	  oenv = (for_stx ? eenv : env);
 	  
@@ -6148,7 +6232,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	    if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) {
 	      scheme_extend_module_rename(for_stx ? post_ex_et_rn : post_ex_rn, self_modidx, name, name, self_modidx, name,
 					  for_stx ? 1 : 0, NULL, NULL, 0);
-              all_simple_renames = 0;
+              *all_simple_renames = 0;
 	    } else
 	      scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name,
 					  for_stx ? 1 : 0, NULL, NULL, 0);
@@ -6186,6 +6270,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	  }
 	  m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0);
 
+          lifted_reqs = scheme_append(scheme_frame_get_require_lifts(eenv), lifted_reqs);
+
 	  oi = scheme_optimize_info_create();
           oi->context = (Scheme_Object *)env->genv->module;
           if (!(rec[drec].comp_flags & COMP_CAN_INLINE))
@@ -6243,7 +6329,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
                          check_require_name, tables,
                          redef_modname, 
                          0, 0, 1, 0,
-                         &all_simple_renames);
+                         all_simple_renames);
 
 	  if (rec[drec].comp)
 	    e = NULL;
@@ -6361,7 +6447,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
       l = (maybe_has_lifts 
            ? scheme_frame_get_end_statement_lifts(cenv) 
            : scheme_null);
-      scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx);
+      scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data);
       maybe_has_lifts = 1;
 
       if (kind == 2)
@@ -6380,6 +6466,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	erec1.value_name = scheme_false;
 	e = scheme_expand_expr(e, nenv, &erec1, 0);
       }
+
+      lifted_reqs = scheme_append(scheme_frame_get_require_lifts(xenv), lifted_reqs);
       
       l = scheme_frame_get_lifts(cenv);
       if (SCHEME_NULLP(l)) {
@@ -6389,7 +6477,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 	p = SCHEME_CDR(p);
       } else {
 	/* Lifts - insert them and try again */
-        all_simple_renames = 0;
+        *all_simple_renames = 0;
         SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l));
 	e = scheme_make_pair(e, scheme_make_integer(0)); /* don't re-compile/-expand */
 	SCHEME_CAR(p) = e;
@@ -6632,7 +6720,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
     env->genv->module->indirect_provides = exis;
     env->genv->module->num_indirect_provides = exicount;
 
-    if (all_simple_renames) {
+    if (*all_simple_renames) {
       env->genv->module->indirect_syntax_provides = exsis;
       env->genv->module->num_indirect_syntax_provides = exsicount;
     } else {
@@ -6645,7 +6733,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 
     env->genv->module->comp_prefix = cenv->prefix;
 
-    if (all_simple_renames) {
+    if (*all_simple_renames) {
       env->genv->module->rn_stx = scheme_true;
     }
 
@@ -6659,6 +6747,13 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
     }
 
     p = SCHEME_STX_CAR(form);
+
+    /* Add lifted requires */
+    if (!SCHEME_NULLP(lifted_reqs)) {
+      lifted_reqs = scheme_reverse(lifted_reqs);
+      first = scheme_append(lifted_reqs, first);
+    }
+
     return scheme_datum_to_syntax(cons(p, first), form, form, 0, 2);
   }
 }
@@ -9045,10 +9140,10 @@ static Scheme_Object *do_require(Scheme_Object *form, Scheme_Comp_Env *env,
                  0, 0, 0, 0,
                  NULL);
 
-  if (rec[drec].comp) {
+  if (rec && rec[drec].comp) {
     /* Dummy lets us access a top-level environment: */
     dummy = scheme_make_environment_dummy(env);
-
+    
     scheme_compile_rec_done_local(rec, drec);
     scheme_default_compile_rec(rec, drec);
     return scheme_make_syntax_compiled(REQUIRE_EXPD, 
@@ -9071,6 +9166,20 @@ require_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *er
   return do_require(form, env, erec, drec);
 }
 
+Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path, 
+                                                  long phase,
+                                                  Scheme_Comp_Env *cenv,
+                                                  Scheme_Object *mark)
+{
+  Scheme_Object *form;
+
+  form = make_require_form(module_path, phase, mark);
+
+  do_require(form, cenv, NULL, 0);
+
+  return form;
+}
+
 /**********************************************************************/
 /*                            dummy forms                             */
 /**********************************************************************/
diff --git a/src/mzscheme/src/schminc.h b/src/mzscheme/src/schminc.h
index 5f08fc194b..33581e2922 100644
--- a/src/mzscheme/src/schminc.h
+++ b/src/mzscheme/src/schminc.h
@@ -11,9 +11,9 @@
    EXPECTED_PRIM_COUNT to the new value, and then USE_COMPILED_STARTUP
    can be set to 1 again. */
 
-#define USE_COMPILED_STARTUP 1
+#define USE_COMPILED_STARTUP 0
 
-#define EXPECTED_PRIM_COUNT 945
+#define EXPECTED_PRIM_COUNT 946
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP
diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h
index 48207e915a..ccd049a4ca 100644
--- a/src/mzscheme/src/schpriv.h
+++ b/src/mzscheme/src/schpriv.h
@@ -362,7 +362,7 @@ extern mz_proc_thread *scheme_master_proc_thread;
 extern THREAD_LOCAL mz_proc_thread *proc_thread_self;
 #endif
 
-extern int scheme_no_stack_overflow;
+extern THREAD_LOCAL int scheme_no_stack_overflow;
 
 typedef struct Scheme_Thread_Set {
   Scheme_Object so;
@@ -2065,11 +2065,22 @@ Scheme_Object *scheme_env_frame_uid(Scheme_Comp_Env *env);
 
 typedef Scheme_Object *(*Scheme_Lift_Capture_Proc)(Scheme_Object *, Scheme_Object **, Scheme_Object *, Scheme_Comp_Env *);
 void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, 
-                                 Scheme_Object *end_stmts, Scheme_Object *context_key);
+                                 Scheme_Object *end_stmts, Scheme_Object *context_key, Scheme_Object *require_lifts);
+void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env);
 Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env);
 Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env);
+Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env);
 Scheme_Object *scheme_generate_lifts_key(void);
 
+Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path, 
+                                                  long phase,
+                                                  Scheme_Comp_Env *cenv,
+                                                  Scheme_Object *mark);
+Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path,
+                                           long phase,
+                                           Scheme_Object *mark,
+                                           void *data);
+
 void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env);
 void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val,
 			     Scheme_Comp_Env *env);
diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h
index 0583c45695..cd5cfe3196 100644
--- a/src/mzscheme/src/schvers.h
+++ b/src/mzscheme/src/schvers.h
@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "4.1.3.9"
+#define MZSCHEME_VERSION "4.1.3.10"
 
 #define MZSCHEME_VERSION_X 4
 #define MZSCHEME_VERSION_Y 1
 #define MZSCHEME_VERSION_Z 3
-#define MZSCHEME_VERSION_W 9
+#define MZSCHEME_VERSION_W 10
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)