Merge branch 'master' of git.racket-lang.org:plt

.gitignore

@@ -9,3 +9,8 @@
 
 # a common convenient place to set the PLTADDON directory to
 /add-on/
+
+# common backups, autosaves, and lock files
+*~
+\#*
+.#*

collects/2htdp/private/img-err.ss

@@ -20,6 +20,7 @@
          lang/posn
          scheme/gui/base
          "../../mrlib/image-core.ss"
+         (prefix-in cis: "../../mrlib/cache-image-snip.ss")
          (for-syntax scheme/base
                      scheme/list))
 
@@ -270,9 +271,26 @@
     [else arg]))
 
 (define (image-snip->image is)
-  (bitmap->image (send is get-bitmap)
-                 (or (send is get-bitmap-mask)
-                     (send (send is get-bitmap) get-loaded-mask))))
+  (let ([bm (send is get-bitmap)])
+    (cond
+      [(not bm)
+       ;; this might mean we have a cache-image-snip% 
+       ;; or it might mean we have a useless snip.
+       (let-values ([(w h) (if (is-a? is cis:cache-image-snip%)
+                               (send is get-size)
+                               (values 0 0))])
+         (make-image (make-polygon
+                      (list (make-point 0 0)
+                            (make-point w 0)
+                            (make-point w h)
+                            (make-point 0 h))
+                      'solid "black")
+                     (make-bb w h h)
+                     #f))]
+      [else
+       (bitmap->image bm
+                      (or (send is get-bitmap-mask)
+                          (send bm get-loaded-mask)))])))
 
 (define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
   (let ([w (send bm get-width)]

collects/2htdp/tests/test-image.ss

@@ -46,6 +46,7 @@
          scheme/class
          scheme/gui/base
          schemeunit
+         (prefix-in 1: htdp/image)
          (only-in lang/htdp-advanced equal~?))
 
 (require (for-syntax scheme/base))
@@ -202,6 +203,14 @@
 (check-close (image-height (rotate 30 (ellipse 0 100 'solid 'blue)))
              (ceiling (* (cos (* pi 1/6)) 100)))
 
+;; zero-sized htdp/image images should also work
+(test (image-width (1:text "" 18 "blue"))
+      =>
+      0)
+(test (image-height (1:rectangle 10 0 'solid "red"))
+      =>
+      0)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  polygon equality

collects/2htdp/universe-request.txt

@@ -0,0 +1,77 @@
+From: Robby Findler <robby@eecs.northwestern.edu>
+Date: June 16, 2009 5:16:50 PM EDT
+To: Matthias Felleisen <matthias@ccs.neu.edu>
+Subject: Fwd: Universe key handler request
+
+I was cleaning out my inbox and found this. Probably too late, but I
+thought I'd still pass it on in case you'd forgotten. 
+
+Robby
+
+Forwarded conversation
+Subject: Universe key handler request
+------------------------
+
+From: Robby Findler <robby@eecs.northwestern.edu>
+Date: Tue, Feb 24, 2009 at 9:22 AM
+To: matthias@ccs.neu.edu
+
+
+Can you make the key handlers in universe take 3 arguments instead of
+2? That is, it takes a world, a key-event and a boolean where the key
+event does not include 'release and the Boolean indicates if the key
+was pressed down or not.
+
+Robby
+
+----------
+From: Matthias Felleisen <matthias@ccs.neu.edu>
+Date: Tue, Feb 24, 2009 at 9:24 AM
+To: Robby Findler <robby@eecs.northwestern.edu>
+
+
+
+I guess. Why is this useful?
+
+
+----------
+From: Matthias Felleisen <matthias@ccs.neu.edu>
+Date: Tue, Feb 24, 2009 at 9:25 AM
+To: Robby Findler <robby@eecs.northwestern.edu>
+
+
+
+P.S. and how would you signal the release of a key?
+
+
+----------
+From: Robby Findler <robby@eecs.northwestern.edu>
+Date: Tue, Feb 24, 2009 at 9:29 AM
+To: Matthias Felleisen <matthias@ccs.neu.edu>
+
+
+the Boolean!
+
+It is useful for multiple key presses that overlap but it is also
+useful that it matches what you think when you look at a keyboard.
+
+Robby
+
+
+----------
+From: Matthias Felleisen <matthias@ccs.neu.edu>
+Date: Tue, Feb 24, 2009 at 10:19 AM
+To: Robby Findler <robby@eecs.northwestern.edu>
+
+
+
+
+Wait. Say I press a key
+
+Ê*------------------------------||-------------------------------------*
+Êkey-press Ê Êholding it down Êthe event handler is called with #t Ê more key presses, no release?
+
+when does the program find out that I have released the key?
+
+
+

collects/2htdp/universe-syntax-parse.ss

@@ -0,0 +1,117 @@
+#lang scheme/load
+
+(module auxs scheme 
+  (define (world->world> proc0)
+    (printf "a world to world function\n")
+    proc0)
+  
+  (define (positive-number> rate0)
+    (printf "a positive number")
+    rate0)
+  
+  ;; String String Syntax[id] -> Syntax 
+  (define (pre-post-name pre post name)
+    (datum->syntax 
+     name (string->symbol (string-append pre (symbol->string (syntax-e name)) post))))
+  
+  (provide (all-defined-out)))
+
+(module clauses scheme 
+  
+  (require syntax/parse (for-syntax scheme 'auxs unstable/syntax)
+           (for-template scheme/base 'auxs))
+  
+  
+  (define-syntax (define-clause stx)
+    (syntax-case stx ()
+      [(_ name (proc p-ctc) (rate r-ctc) ...)
+       (with-syntax ([name-clause (pre-post-name "" "-clause" #'name)]
+                     [(rate0 ...) (generate-temporaries #'(rate ...))])
+         (with-syntax ([((thing ...) ...) #'((#:with rate #'(r-ctc rate0)) ...)])
+           #`
+           (begin
+             (provide name name-clause)
+             
+             (define-syntax (name . x)
+               (raise-syntax-error 'name "used out of context" x))
+             
+             (define-syntax-class name-clause
+               #:description (format "~a" 'name)
+               #:literals (name)
+               #:attributes (proc rate ...)
+               (pattern (name proc0:expr)
+                        #:with (rate0 ...) (map (lambda (x) #'0) '(rate0 ...))
+                        #:with proc #'(world->world proc0)
+                        thing ... ...)
+               (pattern (on-tick proc0:expr (~var rate0 expr) ...)
+                        #:with proc #'(world->world> proc0)
+                        thing ... ...))
+             )))]))
+  
+  (define-clause on-mouse (proc world-nat-nat-mouse->world))
+  (define-clause on-tick (proc world->world) (rate (lambda (x) 1/28)))
+  
+  ;; --- on-tick --- 
+  #|
+  (define-syntax (on-tick . x)
+    (raise-syntax-error 'on-tick "used out of context" x))
+  
+  (define-syntax-class on-tick-clause 
+    #:description "on tick"
+    #:literals (on-tick)
+    #:attributes (proc rate)
+    (pattern (on-tick proc0:expr)
+             #:with proc #'(world->world proc0)
+             #:with rate #'1/28)
+    (pattern (on-tick proc0:expr rate0:expr)
+             #:with proc #'(world->world> proc0)
+             #:with rate #'(positive-number> rate0)))
+  
+  (provide on-tick on-tick-clause)
+  |#
+  ;; --- on-draw --- 
+  (define-syntax (on-draw . x)
+    (raise-syntax-error 'on-draw "used out of context" x))
+  
+  (define-syntax-class on-draw-clause 
+    #:description "on draw"
+    #:literals (on-draw)
+    #:attributes (proc width height)
+    (pattern (on-draw proc0:expr)
+             #:with proc #'(wrap worldxkey->world proc0)
+             #:with width #'#f
+             #:with height #'#f)
+    (pattern (on-draw proc0:expr width0:expr height0:expr)
+             #:with proc #'(worldxkey->world> proc0)
+             #:with width #'(natural-number> width0)
+             #:with height #'(natural-number> height0)))
+  
+  (provide on-draw on-draw-clause))
+
+(module utest scheme 
+  (require (for-syntax syntax/parse 'clauses))
+  
+  (define-syntax (big-bang stx)
+    (syntax-parse stx
+      [(big-bang world0:expr 
+                 (~or (~optional otc:on-tick-clause)
+                      ; (~optional omc:on-mouse-clause)
+                      (~optional odc:on-draw-clause))
+                 ...)
+       #`(printf "~s\n"
+                 '(bb world0
+                      #,(if (attribute otc)
+                            #'otc.rate 
+                            #'1/28)
+                      #,(if (attribute odc)
+                            #'odc.proc
+                            #''not-draw)))]))
+  
+  (big-bang 0)   
+  (big-bang 1 (on-tick add1))
+  (big-bang 2 (on-tick add1 1/2))
+  (big-bang 3 (on-draw add1 1/2 1/3))
+  ; (big-bang 4 (on-mouse add1 1 2))
+  )
+
+(require 'utest)

collects/2htdp/universe.ss

@@ -7,8 +7,6 @@
    -- take out counting; replace by 0.25 delay
 
    -- make window resizable :: why
-   -- what if clauses are repeated in world and/or universe descriptions? 
-   -- what if the initial world or universe state is omitted? the error message is bad then. 
 |#
 
 (require (for-syntax "private/syn-aux.ss" scheme/function)

collects/compiler/commands/c-ext.ss

@@ -7,7 +7,7 @@
 
 (require (prefix-in compiler:option: "../option.ss")
          "../compiler.ss"
-         tool/command-name
+         raco/command-name
          mzlib/cmdline
          dynext/file
          dynext/compile

collects/compiler/commands/decompile.ss

@@ -1,6 +1,6 @@
 #lang scheme/base
 (require scheme/cmdline
-         tool/command-name
+         raco/command-name
          compiler/zo-parse
          compiler/decompile
          scheme/pretty)

collects/compiler/commands/exe-dir.ss

@@ -1,6 +1,6 @@
 #lang scheme/base
 (require scheme/cmdline
-         tool/command-name
+         raco/command-name
          compiler/distribute)
 
 (define verbose (make-parameter #f))

collects/compiler/commands/exe.ss

@@ -1,6 +1,6 @@
 #lang scheme/base
 (require scheme/cmdline
-         tool/command-name
+         raco/command-name
          compiler/private/embed
          dynext/file)
 

collects/compiler/commands/expand.ss

@@ -1,6 +1,6 @@
 #lang scheme/base
 (require scheme/cmdline
-         tool/command-name
+         raco/command-name
          scheme/pretty)
 
 (define source-files

collects/compiler/commands/info.ss

@@ -1,6 +1,6 @@
 #lang setup/infotab
 
-(define racket-tools
+(define raco-commands
   '(("make" compiler/commands/make "compile source to bytecode" 100)
     ("exe" compiler/commands/exe "create executable" 20)
     ("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10)

collects/compiler/commands/make.ss

@@ -1,6 +1,6 @@
 #lang scheme/base
 (require scheme/cmdline
-         tool/command-name
+         raco/command-name
          compiler/cm
          "../compiler.ss"
          dynext/file)

collects/compiler/commands/pack.ss

@@ -1,6 +1,6 @@
 #lang scheme/base
 (require scheme/cmdline
-         tool/command-name
+         raco/command-name
          setup/pack
          setup/getinfo
          compiler/distribute)

collects/drscheme/acks.ss

@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
 
 (provide get-general-acks
          get-translating-acks

collects/drscheme/arrow.ss

@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
 
 (require scheme/class
          scheme/math

collects/drscheme/default-code-style.ss

@@ -1,4 +1,4 @@
-(module default-code-style mzscheme
+#lang racket/base
   (provide color-default-code-styles
            bw-default-code-styles
            code-style-color
@@ -24,4 +24,4 @@
           (list 'unbound-variable (make-code-style "red" #f #f #f))
           (list 'bound-variable (make-code-style "navy" #f #f #f))
           (list 'primitive (make-code-style "navy" #f #f #f))
-          (list 'constant (make-code-style '(51 135 39) #f #f #f)))))
+          (list 'constant (make-code-style '(51 135 39) #f #f #f))))

collects/drscheme/drscheme.ss

@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
 (require scheme/gui/base "private/key.ss")
 
 (define debugging? (getenv "PLTDRDEBUG"))

collects/drscheme/installer.ss

@@ -1,4 +1,4 @@
-(module installer mzscheme
+#lang racket/base
   (require mzlib/file
            mzlib/etc
            launcher)
@@ -18,4 +18,4 @@
        (mred-program-launcher-path "DrScheme")
        (cons
         `(exe-name . "DrScheme")
-        (build-aux-from-path (build-path (collection-path "drscheme") "drscheme")))))))
+        (build-aux-from-path (build-path (collection-path "drscheme") "drscheme"))))))

collects/drscheme/main.ss

@@ -1,2 +1,2 @@
-(module main scheme/base
-  (require "drscheme.ss"))
+#lang racket/base
+(require "drscheme.ss")

collects/drscheme/private/app.ss

@@ -1,10 +1,8 @@
 #lang scheme/unit
 
-(require mzlib/class
-         mzlib/list
-         scheme/file
+(require racket/class
          string-constants
-         mred
+         racket/gui/base
          framework
          browser/external
          setup/getinfo

collects/drscheme/private/bindings-browser.ss

@@ -1,4 +1,4 @@
-#lang mzscheme
+#lang racket/base
 #|
 
 CODE COPIED (with permission ...) from syntax-browser.ss
@@ -9,13 +9,10 @@ Marshalling (and hence the 'read' method of the snipclass omitted for fast proto
 |#
 
 
-  (require mzlib/pretty
-           mzlib/list
-           mzlib/class
-           mred
-           mzlib/match
-           mzlib/string
-           mzlib/contract)
+  (require racket/pretty
+           racket/class
+           racket/gui/base
+           racket/contract)
   
   (provide render-bindings/snip)
 
@@ -64,7 +61,7 @@ Marshalling (and hence the 'read' method of the snipclass omitted for fast proto
                     ; how to enrich the notion of an output-port to get 'bold'ing to 
                     ; work otherwise...
                     (let* ([before (send output-text last-position)])
-                      (pretty-print (syntax-object->datum stx))
+                      (pretty-print (syntax->datum stx))
                       (let* ([post-newline (send output-text last-position)])
                         (send output-text delete post-newline) ; delete the trailing \n. yuck!
                         (send output-text insert " ")
@@ -164,7 +161,7 @@ Marshalling (and hence the 'read' method of the snipclass omitted for fast proto
   
   (define black-style-delta (make-object style-delta% 'change-normal-color))
   (define green-style-delta (make-object style-delta%))
-  (send green-style-delta set-delta-foreground "forest green")
+  (void (send green-style-delta set-delta-foreground "forest green"))
 
   (define turn-snip%
     (class snip%

collects/drscheme/private/bitmap-message.ss

@@ -1,6 +1,6 @@
-#lang scheme
+#lang racket/base
 
-(require mred/mred)
+(require racket/gui/base racket/class)
 (provide bitmap-message%)
 
 (define bitmap-message%

collects/drscheme/private/debug.ss

@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
 
 #|
 
@@ -10,11 +10,11 @@ profile todo:
 
 (require errortrace/errortrace-key
          scheme/unit
-         scheme/contract
+         racket/contract
          errortrace/stacktrace
-         scheme/class
-         scheme/path
-         scheme/gui/base
+         racket/class
+         racket/path
+         racket/gui/base
          string-constants
          framework
          framework/private/bday
@@ -23,9 +23,9 @@ profile todo:
          "bindings-browser.ss"
          net/sendurl
          net/url
-         scheme/match
+         racket/match
          mrlib/include-bitmap
-         (for-syntax scheme/base))
+         (for-syntax racket/base))
 
 (define orig (current-output-port))
 

collects/drscheme/private/drscheme-normal.ss

@@ -1,12 +1,12 @@
-#lang scheme/base
+#lang racket/base
 
 (require mred
-         scheme/class
-         scheme/cmdline
-         scheme/list
+         racket/class
+         racket/cmdline
+         racket/list
          framework/private/bday
          framework/splash
-         scheme/file
+         racket/file
          "eb.ss")
 
 (define files-to-open (command-line #:args filenames filenames))

collects/drscheme/private/drsig.ss

@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
 (require scheme/unit)
 
 (provide drscheme:eval^

collects/drscheme/private/eb.ss

@@ -1,7 +1,7 @@
-#lang scheme/base
-(require scheme/class
+#lang racket/base
+(require racket/class
          framework/splash
-         scheme/gui/base)
+         racket/gui/base)
 
 (provide install-eb)
 (define (install-eb)

collects/drscheme/private/embedded-snip-utils.ss

@@ -1,6 +1,6 @@
-#lang scheme/base
-(require scheme/class
-         scheme/gui/base)
+#lang racket/base
+(require racket/class
+         racket/gui/base)
 
 (provide get-enclosing-editor-frame)
 

collects/drscheme/private/eval.ss

@@ -1,9 +1,9 @@
-#lang mzscheme
+#lang racket/base
 
   (require mred
-           mzlib/unit
-           mzlib/port
-           mzlib/class
+           scheme/unit
+           racket/port
+           racket/class
            syntax/toplevel
            framework
            "drsig.ss")
@@ -11,7 +11,7 @@
   ;; to ensure this guy is loaded (and the snipclass installed) in the drscheme namespace & eventspace
   ;; these things are for effect only!
   (require mrlib/cache-image-snip
-           (prefix image-core: mrlib/image-core))
+           (prefix-in image-core: mrlib/image-core))
   
   (define op (current-output-port))
   (define (oprintf . args) (apply fprintf op args))
@@ -173,7 +173,7 @@
       (error-print-width 250)
       (current-ps-setup (make-object ps-setup%))
       
-      (current-namespace (make-namespace 'empty))
+      (current-namespace (make-empty-namespace))
       (for-each (λ (x) (namespace-attach-module drscheme:init:system-namespace x))
                 to-be-copied-module-names))
     

collects/drscheme/private/font.ss

@@ -1,8 +1,8 @@
-#lang mzscheme
-  (require mzlib/unit
-           mzlib/class
+#lang racket/base
+  (require scheme/unit
+           racket/class
+           racket/gui/base
            "drsig.ss"
-           mred
            framework
            string-constants)
   

collects/drscheme/private/frame.ss

@@ -1,9 +1,8 @@
 #lang scheme/unit
   (require string-constants
-           mzlib/match
-           mzlib/class
-           mzlib/string
-           mzlib/list
+           racket/match
+           racket/class
+           racket/string
            "drsig.ss"
            mred
            framework
@@ -11,7 +10,7 @@
            net/head
            setup/plt-installer
            help/bug-report
-           scheme/file)
+           racket/file)
   
   (import [prefix drscheme:unit: drscheme:unit^]
           [prefix drscheme:app: drscheme:app^]

collects/drscheme/private/get-extend.ss

@@ -1,6 +1,6 @@
 #lang scheme/unit
 
-(require scheme/class
+(require racket/class
          "drsig.ss")
 
 (import [prefix drscheme:unit: drscheme:unit^]

collects/drscheme/private/help-desk.ss

@@ -1,9 +1,9 @@
 #lang scheme/unit
 
-(require scheme/gui/base
+(require racket/gui/base
          browser/external
          framework
-         scheme/class
+         racket/class
          net/url
          setup/dirs
          help/search

collects/drscheme/private/honu-logo.ss

@@ -1,8 +1,8 @@
-#lang scheme/base
+#lang racket/base
 (provide draw-honu)
 
-(require scheme/class
-         scheme/gui/base
+(require racket/class
+         racket/gui/base
          "palaka.ss")
 
 (define pi (atan 0 -1))

collects/drscheme/private/init.ss

@@ -1,8 +1,7 @@
 #lang scheme/unit
   (require string-constants
            "drsig.ss"
-           mzlib/list
-           mred)
+           racket/gui/base)
   
   
   (import)

collects/drscheme/private/insert-large-letters.ss

@@ -2,7 +2,7 @@
 
 (require typed/mred/mred
          typed/framework/framework
-         scheme/class
+         racket/class
          string-constants/string-constant)
 
 

collects/drscheme/private/key.ss

@@ -1,4 +1,4 @@
-#lang mzscheme
+#lang racket/base
   (provide break-threads)
   (define super-cust (current-custodian))
   (define first-child (make-custodian))

collects/drscheme/private/label-frame-mred.ss

@@ -1,28 +1,28 @@
-#lang mzscheme
-  (require mred
-           mzlib/class)
-  (provide (all-from-except mred frame%)
-           (rename registering-frame% frame%)
+#lang racket/base
+  (require racket/gui/base
+           racket/class)
+  (provide (except-out (all-from-out racket/gui/base) frame%)
+           (rename-out [registering-frame% frame%])
            lookup-frame-name)
   
   (define (lookup-frame-name frame)
     (semaphore-wait label-sema)
     (begin0
-      (hash-table-get label-ht frame (λ () #f))
+      (hash-ref label-ht frame (λ () #f))
       (semaphore-post label-sema)))
   
   (define label-sema (make-semaphore 1))
-  (define label-ht (make-hash-table 'weak))
+  (define label-ht (make-weak-hasheq))
   
   (define registering-frame%
     (class frame%
       (define/override (set-label x)
         (semaphore-wait label-sema)
-        (hash-table-put! label-ht this x)
+        (hash-set! label-ht this x)
         (semaphore-post label-sema)
         (super set-label x))
       (inherit get-label)
       (super-instantiate ())
       (semaphore-wait label-sema)
-      (hash-table-put! label-ht this (get-label))
+      (hash-set! label-ht this (get-label))
       (semaphore-post label-sema)))

collects/drscheme/private/language-configuration.ss

@@ -1,13 +1,13 @@
-#lang scheme/base
+#lang racket/base
   (require scheme/unit
            mrlib/hierlist
-           scheme/class
-           scheme/contract
-           scheme/string
-           scheme/list
+           racket/class
+           racket/contract
+           racket/string
+           racket/list
+           racket/gui/base
            "drsig.ss"
            string-constants
-           mred
            framework
            setup/getinfo
            syntax/toplevel
@@ -1252,7 +1252,12 @@
                (message-box
                 (string-constant drscheme)
                 (format
-                 "The drscheme-language-position, drscheme-language-modules, drscheme-language-numbers, and drscheme-language-readers specifications aren't correct. Expected (listof (cons string (listof string))), (listof (listof string)), (listof (listof number)), (listof string), (listof string), and (listof module-spec) respectively, where the lengths of the outer lists are the same. Got ~e, ~e, ~e, ~e, ~e, and ~e"
+                 (string-append
+                  "The drscheme-language-position, drscheme-language-modules, drscheme-language-numbers,"
+                  " and drscheme-language-readers specifications aren't correct. Expected"
+                  " (listof (cons string (listof string))), (listof (listof string)), (listof (listof number)), (listof string),"
+                  " (listof string), and (listof module-spec) respectively, where the lengths of the outer lists are the same."
+                  " Got ~e, ~e, ~e, ~e, ~e, and ~e")
                  lang-positions
                  lang-modules
                  numberss
@@ -1431,7 +1436,7 @@
       (let ([words #f])
         (λ ()
           (unless words
-            (set! words (text:get-completions/manuals '(scheme/base scheme/contract))))
+            (set! words (text:get-completions/manuals '(racket/base racket/contract))))
           words)))
     
     (define get-all-manual-keywords

collects/drscheme/private/language-object-contract.ss

@@ -1,14 +1,14 @@
 #reader scribble/reader
-#lang scheme/base
-(require (for-syntax scheme/base)
+#lang racket/base
+(require (for-syntax racket/base)
          scribble/srcdoc
-         scheme/class
-         scheme/gui/base
-         scheme/contract
+         racket/class
+         racket/gui/base
+         racket/contract
          "recon.ss")
-(require/doc scheme/base scribble/manual)
+(require/doc racket/base scribble/manual)
 
-(require (for-meta 2 scheme/base))
+(require (for-meta 2 racket/base))
 
 (provide language-object-abstraction)
 

collects/drscheme/private/language.ss

@@ -9,17 +9,17 @@
          
          ;; NOTE: this module instantiates stacktrace itself, so we have
          ;; to be careful to not mix that instantiation with the one
-         ;; drscheme/private/debug.ss does. errortrace-lib's is for the
+         ;; drracket/private/debug.ss does. errortrace-lib's is for the
          ;; compilation handling, DrScheme's is for profiling and test coverage
          ;; (which do not do compilation)
          (prefix-in el: errortrace/errortrace-lib) 
          
          mzlib/pconvert
-         scheme/pretty
+         racket/pretty
          mzlib/struct
-         scheme/class
-         scheme/file
-         scheme/list
+         racket/class
+         racket/file
+         racket/list
          compiler/embed
          launcher
          mred

collects/drscheme/private/launcher-bootstrap.ss

@@ -1,8 +1,8 @@
-#lang scheme/base
+#lang racket/base
 
 (provide startup)
 
-(require scheme/file)
+(require racket/file)
 
 (define (read-from-string s) (read (open-input-string s)))
 

collects/drscheme/private/launcher-mred-bootstrap.ss

@@ -1,9 +1,9 @@
-#lang scheme/base
+#lang racket/base
 
-(require scheme/gui/base "launcher-bootstrap.ss")
+(require racket/gui/base "launcher-bootstrap.ss")
 
 (current-namespace (make-gui-empty-namespace))
-(namespace-require 'scheme/gui/base)
-(namespace-require 'scheme/class)
+(namespace-require 'racket/gui/base)
+(namespace-require 'racket/class)
 
 (startup)

collects/drscheme/private/launcher-mz-bootstrap.ss

@@ -1,8 +1,8 @@
-#lang scheme/base
+#lang racket/base
 
 (require "launcher-bootstrap.ss")
 
 (current-namespace (make-base-empty-namespace))
-(namespace-require 'scheme/base)
+(namespace-require 'racket/base)
 
 (startup)

collects/drscheme/private/link.ss

@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
 (require scheme/unit
          "modes.ss"
          "font.ss"

collects/drscheme/private/main.ss

@@ -7,7 +7,7 @@
          framework
          mzlib/class
          mzlib/list
-         scheme/path
+         racket/path
          browser/external
          setup/plt-installer)
 

collects/drscheme/private/modes.ss

@@ -1,7 +1,7 @@
 #lang scheme/unit
   (require string-constants
-           mzlib/class
-           mzlib/list
+           racket/class
+	   racket/list
            framework
            "drsig.ss")
   
@@ -23,7 +23,7 @@
   
   (define (not-a-language-language? l)
     (and (not (null? l))
-         (equal? (car (last-pair l))
+         (equal? (last l)
                  (string-constant no-language-chosen))))
   
   (define (add-initial-modes)

collects/drscheme/private/module-browser.ss

@@ -1,7 +1,7 @@
-#lang scheme/base
+#lang racket/base
 
 (require mred
-         scheme/class
+         racket/class
          syntax/moddep
          syntax/toplevel
          framework/framework
@@ -9,7 +9,7 @@
          mrlib/graph
          "drsig.ss"
          scheme/unit
-         scheme/async-channel
+         racket/async-channel
          setup/private/lib-roots)
 
 (define-struct req (filename key))

collects/drscheme/private/module-language-tools.ss

@@ -1,12 +1,12 @@
-#lang scheme/base
+#lang racket/base
 (provide module-language-tools@)
 (require mrlib/switchable-button 
          mrlib/bitmap-label
-         scheme/contract
+         racket/contract
          framework
          scheme/unit
-         scheme/class
-         scheme/gui/base
+         racket/class
+         racket/gui/base
          "drsig.ss")
 
 (define op (current-output-port))

collects/drscheme/private/module-language.ss

@@ -1,11 +1,11 @@
-#lang scheme/base
+#lang racket/base
 
 (provide module-language@)
 (require scheme/unit
-         scheme/class
-         scheme/list
-         scheme/path
-         scheme/contract
+         racket/class
+         racket/list
+         racket/path
+         racket/contract
          mred
          compiler/embed
          compiler/cm
@@ -382,7 +382,7 @@
                           #:literal-expression
                           (begin
                             (parameterize ([current-namespace (make-base-empty-namespace)])
-                              (namespace-require 'scheme/base)
+                              (namespace-require 'racket/base)
                               (compile 
                                `(namespace-require '',(string->symbol (path->string short-program-name))))))
                           #:cmdline '("-U" "--")))))
@@ -672,7 +672,7 @@
       (raise-hopeless-syntax-error "bad syntax in name position of module"
                                    stx name))
     (when filename (check-filename-matches filename name* stx))
-    (let* (;; rewrite the module to use the scheme/base version of `module'
+    (let* (;; rewrite the module to use the racket/base version of `module'
            [mod  (datum->syntax #'here 'module mod)]
            [expr (datum->syntax stx `(,mod ,name ,lang . ,body) stx stx)])
       (values name lang expr)))

collects/drscheme/private/multi-file-search.ss

@@ -2,8 +2,8 @@
   (require framework
            mzlib/class
            mred
-           scheme/file
-           scheme/path
+           racket/file
+           racket/path
            mzlib/thread
            mzlib/async-channel
            string-constants

collects/drscheme/private/number-snip.ss

@@ -1,6 +1,6 @@
-#lang mzscheme
+#lang racket/base
   (require mred
-           mzlib/class
+           racket/class
            framework)
   
   (provide snip-class)

collects/drscheme/private/palaka.ss

@@ -1,5 +1,5 @@
-#lang scheme/base
-(require scheme/class scheme/gui/base)
+#lang racket/base
+(require racket/class racket/gui/base)
 (provide draw-palaka palaka-pattern-size)
 
 (define scale 1)

collects/drscheme/private/prefs-contract.ss

@@ -1,6 +1,6 @@
-#lang scheme/base
+#lang racket/base
 
-(require (for-syntax scheme/base)
+(require (for-syntax racket/base)
          framework/framework)
 
 (provide (rename-out [-preferences:get preferences:get])

collects/drscheme/private/profile-drs.ss

@@ -1,6 +1,6 @@
-#lang scheme/base
-(require scheme/gui/base
-         scheme/class
+#lang racket/base
+(require racket/gui/base
+         racket/class
          profile/sampler
          profile/render-text
          profile/analyzer

collects/drscheme/private/recon.ss

@@ -1,5 +1,5 @@
-#lang scheme/base
-(require (for-syntax scheme/base))
+#lang racket/base
+(require (for-syntax racket/base))
 (provide reconstitute)
 
 (begin-for-syntax

collects/drscheme/private/rep.ss

@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
 
 #|
 
@@ -20,15 +20,15 @@ TODO
 ;;          user's io ports, to aid any debugging printouts.
 ;;          (esp. useful when debugging the users's io)
 
-(require scheme/class
-         scheme/path
-         scheme/pretty
+(require racket/class
+         racket/path
+         racket/pretty
          scheme/unit
-         scheme/list
+         racket/list
          
          string-constants
          setup/xref
-         scheme/gui/base
+         racket/gui/base
          framework
          browser/external
          "drsig.ss"

collects/drscheme/private/stick-figures.ss

@@ -1,7 +1,7 @@
-#lang mzscheme
-  (require mzlib/class
-           mzlib/pretty
-           mred)
+#lang racket/base
+  (require racket/class
+           racket/pretty
+           racket/gui/base)
   
   (define head-size 40)
   (define small-bitmap-factor 1/2)

collects/drscheme/private/tools.ss

@@ -1,9 +1,9 @@
 #lang scheme/unit
 
-(require scheme/class
-         scheme/list
-         scheme/runtime-path
-         scheme/contract
+(require racket/class
+         racket/list
+         racket/runtime-path
+         racket/contract
          setup/getinfo
          mred
          framework
@@ -13,7 +13,7 @@
          mrlib/switchable-button
 string-constants)
 
-(require (for-syntax scheme/base scheme/match))
+(require (for-syntax racket/base racket/match))
 
 (import [prefix drscheme:frame: drscheme:frame^]
         [prefix drscheme:unit: drscheme:unit^]

collects/drscheme/private/tracing.ss

@@ -1,12 +1,12 @@
-#lang scheme/base
+#lang racket/base
 
-(require scheme/contract
+(require racket/contract
          scheme/unit
-         scheme/class
-         scheme/path
-         scheme/port
-         scheme/list
-         scheme/gui/base
+         racket/class
+         racket/path
+         racket/port
+         racket/list
+         racket/gui/base
          string-constants
          framework
          (prefix-in tr: trace/stacktrace)

collects/drscheme/private/ts.ss

@@ -1,5 +1,4 @@
-#reader scribble/reader
-#lang scheme/base
+#lang at-exp racket/base
 
 (require scribble/decode
          scribble/manual)

collects/drscheme/private/unit.ss

@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
 #|
 
 closing:
@@ -11,12 +11,12 @@ module browser threading seems wrong.
 
 |#
 
-  (require scheme/contract
+  (require racket/contract
            scheme/unit
-           scheme/class
-           scheme/path
-           scheme/port
-           scheme/list
+           racket/class
+           racket/path
+           racket/port
+           racket/list
            string-constants
            framework
            mrlib/name-message

collects/drscheme/sprof.ss

@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
 (require scheme/gui/base
          framework
          scheme/class)

collects/drscheme/syncheck-drscheme-button.ss

@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
 (require scheme/class 
          scheme/gui/base
          string-constants/string-constant)

collects/drscheme/syncheck.ss

@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
 #|
 
 Check Syntax separates two classes of identifiers,
@@ -2276,16 +2276,28 @@ If the namespace does not, they are colored the unbound color.
       (parameterize ([current-namespace user-namespace]
                      [current-directory user-directory]
                      [current-load-relative-directory user-directory])
-        (let ([ans (with-handlers ([exn:fail? (λ (x) #f)])
-                     (cond
-                       [(module-path-index? datum)
-                        (resolved-module-path-name 
-                         (module-path-index-resolve datum))]
-                       [else
-                        (resolved-module-path-name 
-                         ((current-module-name-resolver) datum #f #f))]))])
-          (and (path? ans)
-               ans))))
+        (let* ([rkt-path/mod-path
+                (with-handlers ([exn:fail? (λ (x) #f)])
+                  (cond
+                    [(module-path-index? datum)
+                     (resolved-module-path-name 
+                      (module-path-index-resolve datum))]
+                    [else
+                     (resolved-module-path-name 
+                      ((current-module-name-resolver) datum #f #f))]))]
+               [rkt-path/f (and (path? rkt-path/mod-path) rkt-path/mod-path)])
+          (let/ec k
+            (unless (path? rkt-path/f) (k rkt-path/f))
+            (when (file-exists? rkt-path/f) (k rkt-path/f))
+            (let* ([bts (path->bytes rkt-path/f)]
+                   [len (bytes-length bts)])
+              (unless (and (len . >= . 4) 
+                           (bytes=? #".rkt" (subbytes bts (- len 4))))
+                (k rkt-path/f))
+              (let ([ss-path (bytes->path (bytes-append (subbytes bts 0 (- len 4)) #".ss"))])
+                (unless (file-exists? ss-path)
+                  (k rkt-path/f))
+                ss-path))))))
     
     ;; make-require-open-menu : path -> menu -> void
     (define (make-require-open-menu file)

collects/drscheme/tool-lib.ss

@@ -1,4 +1,4 @@
-#lang at-exp scheme/base
+#lang at-exp racket/base
 
 #|
 
@@ -9,7 +9,7 @@ all of the names in the tools library, for use defining keybindings
 |#
 (require scheme/class
          scheme/gui/base
-         scheme/unit
+         (except-in scheme/unit struct)
          scheme/contract
          scheme/class
          

collects/drscheme/tool.ss

@@ -1,4 +1,5 @@
-(module tool mzscheme
-  (require "private/drsig.ss")
-  (provide drscheme:tool^
-           drscheme:tool-exports^))
+#lang racket/base
+(require "private/drsig.ss")
+(provide drscheme:tool^
+	 drscheme:tool-exports^)
+

collects/help/help.ss

@@ -1,10 +1,12 @@
 #lang scheme/base
 
-(require "search.ss" scheme/cmdline scheme/list scheme/string)
+(require "search.ss" scheme/cmdline scheme/list scheme/string
+         raco/command-name) 
 
 ;; Minimal command-line arguments, the query string can contain all
 ;; kinds of magic.
 (command-line
+ #:program (short-program+command-name)
  #:handlers
  (lambda (_ . ts)
    (if (null? ts)

collects/help/info.ss

@@ -1,4 +1,4 @@
 #lang setup/infotab
 
 (define post-install-collection "installer.ss")
-(define racket-tools '(("docs" help/help "search and view documentation" 100)))
+(define raco-commands '(("docs" help/help "search and view documentation" 100)))

collects/help/installer.ss

@@ -27,7 +27,7 @@
       (parameterize ([current-launcher-variant variant])
         (mk-launcher '("-l-" "help/help")
                      (mk-path "plt-help")       ;; change to "Racket Docs"
-                     `([exe-name . "plt-help"]  ;; get rid of this (in favor of 'racket-tool docs')
+                     `([exe-name . "plt-help"]  ;; get rid of this (in favor of 'raco docs')
                        [relative? . #t]
                        [framework-root . #f]
                        [dll-dir . #f]

collects/lang/private/teach.ss

@@ -38,7 +38,8 @@
 	   mzlib/list
 	   mzlib/math
            scheme/match
-           "set-result.ss")
+           "set-result.ss"
+           (only racket/base define-struct))
   (require-for-syntax "teachhelp.ss"
                       "teach-shared.ss"
 		      syntax/kerncase
@@ -753,12 +754,13 @@
 			      (lambda (def-proc-names)
 				(with-syntax ([(def-proc-name ...) def-proc-names]
 					      [(proc-name ...) proc-names])
-				  (stepper-syntax-property #`(define-values (def-proc-name ...)
-						       (let ()
-							 (define-struct name_ (field_ ...) (make-inspector))
-							 (values proc-name ...)))
-						   'stepper-define-struct-hint
-						   stx))))])
+				  (stepper-syntax-property 
+                                   #`(define-values (def-proc-name ...)
+                                       (let ()
+                                         (define-struct name_ (field_ ...) #:transparent #:constructor-name #,(car proc-names))
+                                         (values proc-name ...)))
+                                   'stepper-define-struct-hint
+                                   stx))))])
                  (let ([defn
                          (quasisyntax/loc stx
                            (begin

collects/meta/contrib/completion/racket-completion.bash

@@ -82,14 +82,14 @@ complete  -F _racket $filenames racket
 complete  -F _racket $filenames gracket
 complete  -F _racket $filenames gracket-text
 
-_rico_planet()
+_raco_planet()
 {
     local cur="${COMP_WORDS[COMP_CWORD]}"
-    local planetcmds=$( echo '' '--help' ;  for x in `rico planet --help 2>&1 | sed -n -e 's/^  \(.[^ ]*\).*/\1/p'` ; do echo ${x} ; done )
+    local planetcmds=$( echo '' '--help' ;  for x in `raco planet --help 2>&1 | sed -n -e 's/^  \(.[^ ]*\).*/\1/p'` ; do echo ${x} ; done )
     COMPREPLY=( $(compgen -W "${planetcmds}" -- ${cur}) )
 }
 
-_rico()
+_raco()
 {
     COMPREPLY=()
     local cur="${COMP_WORDS[COMP_CWORD]}"
@@ -101,10 +101,10 @@ _rico()
 
     if [ $COMP_CWORD -eq 1 ]; then
       # removing the empty string on the next line breaks things.  such as my brain.
-      local cmds=$( echo '' '--help' ;  for x in `racket -e '(begin (require rico/all-tools) (for ([(k v) (all-tools)]) (printf "~a\n" k)))'` ; do echo ${x} ; done )
+      local cmds=$( echo '' '--help' ;  for x in `racket -e '(begin (require raco/all-tools) (for ([(k v) (all-tools)]) (printf "~a\n" k)))'` ; do echo ${x} ; done )
       COMPREPLY=($(compgen -W "${cmds}" -- ${cur}))  
     elif [ $COMP_CWORD -eq 2 ]; then
-      # Here we'll handle the main rico commands
+      # Here we'll handle the main raco commands
       local prev="${COMP_WORDS[1]}"
       case "${prev}" in
         make)
@@ -118,7 +118,7 @@ _rico()
           esac
           ;;
         planet)
-          _rico_planet
+          _raco_planet
           ;;
         --help)
           ;;
@@ -132,5 +132,6 @@ _rico()
     return 0
 }
 
-complete -F _rico rico
-complete -F _rico racket-tool
+complete -F _raco rico
+complete -F _raco racket-tool
+complete -F _raco raco

collects/meta/contrib/rubber/slatex.py

@@ -0,0 +1,152 @@
+"""
+sLaTeX support for Rubber.
+"""
+
+from os import unlink
+from os.path import exists, getmtime, join
+
+import rubber
+from rubber import _, msg, Depend, DependLeaf
+
+def run(doc, env, base):
+	msg.progress(_("running slatex on %s") % doc.src_base)
+	if env.execute(["slatex", "-n", base], {}):
+		msg.error(_("Error executing slatex"))
+		return 1
+			
+	doc.must_compile = 1
+	return 0
+
+def slatex_needed(target, srcs):
+	if not exists(target):
+		msg.log(_("File %s does not exist") % target, pkg="slatex")
+		return 1
+	for src in srcs:
+		if getmtime(target) < getmtime(src):
+			msg.log(_("File %s older than %s") % (target, src), pkg="slatex")
+			return 1
+	return 0
+
+class RubberDep (Depend):
+	# Base is the slatex module
+	# Target is the autogenerated file (i.e. .Z# + doc.src_base + ".tex")
+	# Sources is a list of sources on which this file depends
+	def __init__ (self, mod, target, srcs):
+		self.mod = mod
+		self.doc = mod.doc
+		self.env = mod.doc.env
+		self.target = target
+		self.srcs = srcs
+		
+		sources = {}
+		for src in srcs:
+			sources[src] = DependLeaf(self.env, src)
+		Depend.__init__(self, self.env,
+			prods=[target],
+			sources=sources)
+		
+		self.urvater = join(self.doc.src_path, self.doc.src_base + ".tex")
+
+	def run(self):
+		# We may have been out of date before any dependency was run,
+		# but by this point we may be up to date since slatex builds
+		# all the files at once.  Otherwise we'll run once per out of
+		# date generated file.
+		if slatex_needed(self.target, self.srcs):
+			run(self.doc, self.env, self.urvater)
+
+class Module (rubber.rules.latex.Module):
+	def __init__ (self, doc, dict):
+		self.base = doc.src_base
+		self.base_file = join(doc.src_path, doc.src_base + ".tex")
+		self.final = join(doc.env.path[0], doc.env.final.prods[0])
+		self.count = 0
+		self.doc = doc
+		self.env = doc.env
+		self.file_deps = {}
+		self.path = doc.src_path
+		self.preamble = False
+
+		def add_scheme_file(dict, others=[]):
+			filename = ".Z" + str(self.count) + self.base + ".tex"
+			path = join(self.path, filename)
+			deps = [dict["pos"]["file"]]
+			if others:
+				deps.extend(others)
+			self.doc.sources[path] = RubberDep(self, path, deps)
+			msg.log(_("Marking %s as dependent on %s") % (path, deps), pkg = "slatex")
+			self.count += 1
+
+		scheme_macros = ["scheme", "schemeresult"]
+
+		scheme_envs = ["schemedisplay",
+			       "schemeresponse",
+			       "schemebox",
+			       "schemeresponsebox"]
+
+		preamble_macros = ["setspecialsymbol",
+				   "setkeyword",
+				   "defschememathescape"]
+
+		def add_preamble_hook(name):
+			def h_preamb(dict):
+				if not self.preamble and slatex_needed(self.final, [self.base_file]):
+					run(self.doc, self.env, self.base_file)
+					self.preamble = True
+			doc.add_hook(name, h_preamb)
+
+		def add_macro_hook(name):
+			def h_macro(dict):
+				add_scheme_file(dict)
+			doc.add_hook(name, h_macro)
+
+		def add_env_hook(name):
+			beg_env = "begin{%s}" % name
+			end_env = "end{%s}" % name
+			def begin_env_hook(dict):
+				def end_env_hook(dict, self=doc, hooks=doc.hooks):
+					self.hooks = hooks
+					self.update_seq()
+				doc.hooks = { end_env : end_env_hook }
+				# \scheme, \schemeresult allowed in these.
+				for macro in scheme_macros:
+					add_macro_hook(macro)
+				doc.update_seq()
+				add_scheme_file(dict)
+			doc.add_hook(beg_env, begin_env_hook)
+
+		for macro in preamble_macros:
+			add_preamble_hook(macro)
+		for macro in scheme_macros:
+			add_macro_hook(macro)
+		for environ in scheme_envs:
+			add_env_hook(environ)
+
+		# handled specially so that we get dependence on the
+		# file being included as well.
+		def h_schemeinput(dict):
+			arg_path = join(self.path, dict["arg"])
+			add_scheme_file(dict, others=[arg_path])
+
+		doc.add_hook("schemeinput", h_schemeinput)
+
+		# schemeregions should generate one file for the entire
+		# thing, so we shouldn't allow the separate scheme
+		# hooks like above.
+		def h_schemeregion(dict, end = "end{schemeregion}"):
+			def end_env_hook(dict, self=doc, hooks=doc.hooks):
+				self.hooks = hooks
+				self.update_seq()
+			doc.hooks = doc.hooks.copy()
+			doc.hooks[end] = end_env_hook
+			for macro in scheme_macros:
+				if macro in doc.hooks:
+					del doc.hooks[macro]
+			for env in scheme_envs:
+				if ("begin{%s}" % env) in doc.hooks:
+					del doc.hooks["begin{%s}" % env]
+			doc.update_seq()
+			add_scheme_file(dict)
+
+		doc.add_hook("begin{schemeregion}", h_schemeregion)
+

collects/meta/dist-specs.ss

@@ -344,7 +344,7 @@ mz-manuals := (scribblings: "main/") ; generates main pages (next line)
               (notes: "COPYING.LIB" "COPYING-libscheme.txt")
               (doc: "doc-license.txt") ; needed (when docs are included)
               (doc+src: "reference/" "guide/" "quick/" "more/"
-                        "foreign/" "inside/" "places/"
+                        "foreign/" "inside/" ;; "places/" <- not ready yet
                         "honu/")
               (doc: "*.{html|css|js|sxref}")
               (scribblings: "{{info|icons}.ss|*.png}" "compiled")
@@ -431,8 +431,8 @@ platform-dependent := ; hook for package rules
 mz-extras :+= (- (package: "setup-plt" #:collection "setup/")
                  (cond (not dr) => (srcfile: "plt-installer{|-sig|-unit}.ss")))
 
-;; -------------------- racket-tool
-mz-extras :+= (package: "tool")
+;; -------------------- raco
+mz-extras :+= (package: "raco")
 
 ;; -------------------- launcher
 mz-extras :+= (- (collects: "launcher")

collects/meta/props

@@ -140,7 +140,7 @@ path/s is either such a string or a list of them.
   ;; need updating if more characters are allowed in the future.
   #rx"[^/.a-zA-Z0-9%_+-]")
 
-(define (validate-path-string path-string who)
+(define (validate-path-string path-string who [only-warn? #f])
   (define (bad why)
     (error* who "invalid path argument, expecting a ~a, got: ~e"
             why path-string))
@@ -149,10 +149,12 @@ path/s is either such a string or a list of them.
              (regexp-match? rx:bad-path path-string))
     (bad "relative `/'-delimited string, no `/' suffix, `//', `.', or `..'"))
   (when (regexp-match? rx:bad-pathchar path-string)
-    (error* who "invalid path argument, ~s is not allowed, got: ~e\n~a~a"
-            (regexp-match rx:bad-pathchar path-string) path-string
-            "(note: if paths with this character are needed, then this"
-            " script needs to be exteded to allow them)")))
+    (if only-warn?
+      (warn "~s is a bad path argument" path-string)
+      (error* who "invalid path argument, ~s is not allowed, got: ~e\n~a~a"
+              (regexp-match rx:bad-pathchar path-string) path-string
+              "(note: if paths with this character are needed, then this"
+              " script needs to be exteded to allow them)"))))
 
 (define (parse-prop-string prop str who)
   (with-handlers ([exn? (lambda (e)
@@ -162,7 +164,7 @@ path/s is either such a string or a list of them.
 
 (define (get-prop path-string prop-name [default get-prop]
                   #:strict? [strict? #f] #:as-string? [as-string? #f])
-  (validate-path-string path-string 'get-prop)
+  (validate-path-string path-string 'get-prop #t) ; no errors
   (let ([upchain
          ;; take the chain going up from the most specific node, so that
          ;; properties of a directory apply to subpaths
@@ -314,8 +316,9 @@ path/s is either such a string or a list of them.
                                sub))))
     (and (or (pair? (tree-subs tree)) (pair? (tree-props tree))) tree))
   (let (;; temp file in the same directory => fail early if cannot write to it
-        ;; and make a rename possible
-        [temp (make-temporary-file (format "~a~~a" this-file))])
+        ;; and make a rename possible; copy from this file to preserve being
+        ;; executable
+        [temp (make-temporary-file (format "~a~~a" this-file) this-file)])
     (dynamic-wind
       void
       (lambda ()
@@ -812,6 +815,7 @@ path/s is either such a string or a list of them.
 "collects/handin-server/web-status-server.ss" drdr:command-line "mzc ~s"
 "collects/help" responsible (robby)
 "collects/help/bug-report.ss" drdr:command-line "mred-text -t ~s"
+"collects/help/help.ss" drdr:command-line "mzc ~s"
 "collects/hierlist/hierlist.ss" drdr:command-line "mred-text -t ~s"
 "collects/honu" responsible (mflatt rafkind)
 "collects/htdp" responsible (matthias)
@@ -897,8 +901,8 @@ path/s is either such a string or a list of them.
 "collects/make" responsible (mflatt)
 "collects/meta" responsible (eli)
 "collects/meta/check-dists.ss" drdr:command-line ""
-"collects/meta/drdr" responsible (jay) drdr:command-line ""
 "collects/meta/contrib/completion/racket-completion.bash" responsible (samth sstrickl) drdr:command-line ""
+"collects/meta/drdr" responsible (jay) drdr:command-line ""
 "collects/mred/edit-main.ss" drdr:command-line "mzc ~s"
 "collects/mred/edit.ss" drdr:command-line "mred-text -t ~s"
 "collects/mred/lang/main.ss" drdr:command-line "mred-text -t ~s"
@@ -1093,7 +1097,7 @@ path/s is either such a string or a list of them.
 "collects/redex/tests/matcher-test.ss" drdr:command-line "mzc ~s"
 "collects/redex/tests/pict-test.ss" drdr:command-line "mzc ~s"
 "collects/redex/tests/rg-test.ss" drdr:command-line "mzc ~s"
-"collects/redex/tests/run-tests.ss" drdr:command-line "mred-text ~s --examples --no-bitmaps" drdr:timeout 180
+"collects/redex/tests/run-tests.ss" drdr:command-line "mred-text ~s --examples --no-bitmaps" drdr:timeout 240
 "collects/redex/tests/term-test.ss" drdr:command-line "mzc ~s"
 "collects/redex/tests/tl-test.ss" drdr:command-line "mzc ~s"
 "collects/repos-time-stamp" responsible (eli)

collects/mzlib/unit.ss

@@ -142,19 +142,22 @@
                                (syntax-case stx ()
                                  [(_ arg ...) (datum->syntax
                                                stx
-                                               (cons (self-name-struct-info-id me)
+                                               (cons ((self-name-struct-info-id me))
                                                      #'(arg ...))
                                                stx
                                                stx)]
-                                 [_ (let ([id (self-name-struct-info-id me)])
+                                 [_ (let ([id ((self-name-struct-info-id me))])
                                       (datum->syntax id
                                                       (syntax-e id)
                                                       stx
                                                       stx))]))
    #:omit-define-syntaxes))
 
+(define-for-syntax option-keywords
+  "#:mutable, #:constructor-name, #:extra-constructor-name, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
+
 ;; Replacement `struct' signature form for `scheme/unit':
-(define-for-syntax (do-struct~ stx type-as-ctr?)
+(define-for-syntax (do-struct~ stx extra-make?)
   (syntax-case stx ()
     ((_ name (field ...) opt ...)
      (begin
@@ -175,53 +178,85 @@
                                             stx
                                             field)])))
                  (syntax->list #'(field ...)))
-       (let-values ([(no-ctr? mutable? no-stx? no-rt?)
-                     (let loop ([opts (syntax->list #'(opt ...))]
-                                [no-ctr? #f]
-                                [mutable? #f]
-                                [no-stx? #f]
-                                [no-rt? #f])
-                       (if (null? opts)
-                           (values no-ctr? mutable? no-stx? no-rt?)
-                           (let ([opt (car opts)])
-                             (case (syntax-e opt)
-                               [(#:omit-constructor)
-                                (if no-ctr?
-                                    (raise-syntax-error #f
-                                                        "redundant option"
-                                                        stx
-                                                        opt)
-                                    (loop (cdr opts) #t mutable? no-stx? no-rt?))]
-                               [(#:mutable)
-                                (if mutable?
-                                    (raise-syntax-error #f
-                                                        "redundant option"
-                                                        stx
-                                                        opt)
-                                    (loop (cdr opts) no-ctr? #t no-stx? no-rt?))]
-                               [(#:omit-define-syntaxes)
-                                (if no-stx?
-                                    (raise-syntax-error #f
-                                                        "redundant option"
-                                                        stx
-                                                        opt)
-                                    (loop (cdr opts) no-ctr? mutable? #t no-rt?))]
-                               [(#:omit-define-values)
-                                (if no-rt?
-                                    (raise-syntax-error #f
-                                                        "redundant option"
-                                                        stx
-                                                        opt)
-                                    (loop (cdr opts) no-ctr? mutable? no-stx? #t))]
-                               [else
-                                (raise-syntax-error #f
-                                                    (string-append
-                                                     "expected a keyword to specify option: "
-                                                     "#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
-                                                    stx
-                                                    opt)]))))]
-                    [(tmp-name) (and type-as-ctr?
-                                     (car (generate-temporaries #'(name))))])
+       (let*-values ([(no-ctr? mutable? no-stx? no-rt? opt-cname)
+                      (let loop ([opts (syntax->list #'(opt ...))]
+                                 [no-ctr? #f]
+                                 [mutable? #f]
+                                 [no-stx? #f]
+                                 [no-rt? #f]
+                                 [cname #f])
+                        (if (null? opts)
+                            (values no-ctr? mutable? no-stx? no-rt? cname)
+                            (let ([opt (car opts)])
+                              (case (syntax-e opt)
+                                [(#:constructor-name #:extra-constructor-name)
+                                 (if cname
+                                     (raise-syntax-error #f
+                                                         "redundant option"
+                                                         stx
+                                                         opt)
+                                     (if (null? (cdr opts))
+                                         (raise-syntax-error #f
+                                                             "missing identifier after option"
+                                                             stx
+                                                             opt)
+                                         (if (identifier? (cadr opts))
+                                             (loop (cddr opts) #f mutable? no-stx? no-rt?
+                                                   (if (eq? (syntax-e opt) '#:extra-constructor-name)
+                                                       (list (cadr opts))
+                                                       (cadr opts)))
+                                             (raise-syntax-error #f
+                                                                 "not an identifier for a constructor name"
+                                                                 stx
+                                                                 (cadr opts)))))]
+                                [(#:omit-constructor)
+                                 (if no-ctr?
+                                     (raise-syntax-error #f
+                                                         "redundant option"
+                                                         stx
+                                                         opt)
+                                     (loop (cdr opts) #t mutable? no-stx? no-rt? cname))]
+                                [(#:mutable)
+                                 (if mutable?
+                                     (raise-syntax-error #f
+                                                         "redundant option"
+                                                         stx
+                                                         opt)
+                                     (loop (cdr opts) no-ctr? #t no-stx? no-rt? cname))]
+                                [(#:omit-define-syntaxes)
+                                 (if no-stx?
+                                     (raise-syntax-error #f
+                                                         "redundant option"
+                                                         stx
+                                                         opt)
+                                     (loop (cdr opts) no-ctr? mutable? #t no-rt? cname))]
+                                [(#:omit-define-values)
+                                 (if no-rt?
+                                     (raise-syntax-error #f
+                                                         "redundant option"
+                                                         stx
+                                                         opt)
+                                     (loop (cdr opts) no-ctr? mutable? no-stx? #t cname))]
+                                [else
+                                 (raise-syntax-error #f
+                                                     (string-append
+                                                      "expected a keyword to specify option: "
+                                                      option-keywords)
+                                                     stx
+                                                     opt)]))))]
+                     [(def-cname) (cond
+                                   [opt-cname (if (pair? opt-cname)
+                                                  (car opt-cname)
+                                                  opt-cname)]
+                                   [extra-make? #f]
+                                   [else (car (generate-temporaries #'(name)))])]
+                     [(cname) (cond
+                               [opt-cname (if (pair? opt-cname)
+                                              (cons def-cname #'name)
+                                              (cons opt-cname opt-cname))]
+                               [extra-make? #f]
+                               [else (cons def-cname #'name)])]
+                     [(self-ctr?) (and cname (bound-identifier=? #'name (cdr cname)))])
          (cons
           #`(define-syntaxes (name)
               #,(let ([e (build-struct-expand-info
@@ -229,19 +264,19 @@
                           #f (not mutable?)
                           #f '(#f) '(#f)
                           #:omit-constructor? no-ctr?
-                          #:constructor-name (and type-as-ctr? (cons #'name tmp-name)))])
-                  (if type-as-ctr?
+                          #:constructor-name def-cname)])
+                  (if self-ctr?
                       #`(make-self-name-struct-info 
                          (lambda () #,e)
-                         (quote-syntax #,tmp-name))
+                         (lambda () (quote-syntax #,def-cname)))
                       e)))
           (let ([names (build-struct-names #'name (syntax->list #'(field ...))
                                            #f (not mutable?)
-                                           #:constructor-name (and type-as-ctr? 
-                                                                   (cons #'name tmp-name)))])
+                                           #:constructor-name def-cname)])
             (cond
              [no-ctr? (cons (car names) (cddr names))]
-             [tmp-name (cons #`(define-values-for-export (#,tmp-name) name) names)]
+             [self-ctr? (cons #`(define-values-for-export (#,def-cname) name) 
+                              names)]
              [else names]))))))
     ((_ name fields opt ...)
      (raise-syntax-error #f
@@ -258,9 +293,9 @@
                          stx))))
 
 (define-signature-form (struct~s stx)
-  (do-struct~ stx #f))
-(define-signature-form (struct~r stx)
   (do-struct~ stx #t))
+(define-signature-form (struct~r stx)
+  (do-struct~ stx #f))
 
 (define-signature-form (struct/ctc stx)
   (parameterize ((error-syntax stx))
@@ -347,7 +382,7 @@
        (raise-stx-err "missing name and fields")))))
 
 ;; Replacement struct/ctc form for `scheme/unit':
-(define-for-syntax (do-struct~/ctc stx type-as-ctr?)
+(define-for-syntax (do-struct~/ctc stx extra-make?)
   (syntax-case stx ()
     ((_ name ([field ctc] ...) opt ...)
      (begin
@@ -368,53 +403,85 @@
                                             stx
                                             field)])))
                  (syntax->list #'(field ...)))
-       (let-values ([(no-ctr? mutable? no-stx? no-rt?)
-                     (let loop ([opts (syntax->list #'(opt ...))]
-                                [no-ctr? #f]
-                                [mutable? #f]
-                                [no-stx? #f]
-                                [no-rt? #f])
-                       (if (null? opts)
-                           (values no-ctr? mutable? no-stx? no-rt?)
-                           (let ([opt (car opts)])
-                             (case (syntax-e opt)
-                               [(#:omit-constructor)
-                                (if no-ctr?
-                                    (raise-syntax-error #f
-                                                        "redundant option"
-                                                        stx
-                                                        opt)
-                                    (loop (cdr opts) #t mutable? no-stx? no-rt?))]
-                               [(#:mutable)
-                                (if mutable?
-                                    (raise-syntax-error #f
-                                                        "redundant option"
-                                                        stx
-                                                        opt)
-                                    (loop (cdr opts) no-ctr? #t no-stx? no-rt?))]
-                               [(#:omit-define-syntaxes)
-                                (if no-stx?
-                                    (raise-syntax-error #f
-                                                        "redundant option"
-                                                        stx
-                                                        opt)
-                                    (loop (cdr opts) no-ctr? mutable? #t no-rt?))]
-                               [(#:omit-define-values)
-                                (if no-rt?
-                                    (raise-syntax-error #f
-                                                        "redundant option"
-                                                        stx
-                                                        opt)
-                                    (loop (cdr opts) no-ctr? mutable? no-stx? #t))]
-                               [else
-                                (raise-syntax-error #f
-                                                    (string-append
-                                                     "expected a keyword to specify option: "
-                                                     "#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
-                                                    stx
-                                                    opt)]))))]
-                    [(tmp-name) (and type-as-ctr?
-                                     (car (generate-temporaries #'(name))))])
+       (let*-values ([(no-ctr? mutable? no-stx? no-rt? opt-cname)
+                      (let loop ([opts (syntax->list #'(opt ...))]
+                                 [no-ctr? #f]
+                                 [mutable? #f]
+                                 [no-stx? #f]
+                                 [no-rt? #f]
+                                 [cname #f])
+                        (if (null? opts)
+                            (values no-ctr? mutable? no-stx? no-rt? cname)
+                            (let ([opt (car opts)])
+                              (case (syntax-e opt)
+                                [(#:constructor-name #:extra-constructor-name)
+                                 (if cname
+                                     (raise-syntax-error #f
+                                                         "redundant option"
+                                                         stx
+                                                         opt)
+                                     (if (null? (cdr opts))
+                                         (raise-syntax-error #f
+                                                             "missing identifier after option"
+                                                             stx
+                                                             opt)
+                                         (if (identifier? (cadr opts))
+                                             (loop (cddr opts) #f mutable? no-stx? no-rt?
+                                                   (if (eq? (syntax-e opt) '#:extra-constructor-name)
+                                                       (list (cadr opts))
+                                                       (cadr opts)))
+                                             (raise-syntax-error #f
+                                                                 "not an identifier for a constructor name"
+                                                                 stx
+                                                                 (cadr opts)))))]
+                                [(#:omit-constructor)
+                                 (if no-ctr?
+                                     (raise-syntax-error #f
+                                                         "redundant option"
+                                                         stx
+                                                         opt)
+                                     (loop (cdr opts) #t mutable? no-stx? no-rt? cname))]
+                                [(#:mutable)
+                                 (if mutable?
+                                     (raise-syntax-error #f
+                                                         "redundant option"
+                                                         stx
+                                                         opt)
+                                     (loop (cdr opts) no-ctr? #t no-stx? no-rt? cname))]
+                                [(#:omit-define-syntaxes)
+                                 (if no-stx?
+                                     (raise-syntax-error #f
+                                                         "redundant option"
+                                                         stx
+                                                         opt)
+                                     (loop (cdr opts) no-ctr? mutable? #t no-rt? cname))]
+                                [(#:omit-define-values)
+                                 (if no-rt?
+                                     (raise-syntax-error #f
+                                                         "redundant option"
+                                                         stx
+                                                         opt)
+                                     (loop (cdr opts) no-ctr? mutable? no-stx? #t cname))]
+                                [else
+                                 (raise-syntax-error #f
+                                                     (string-append
+                                                      "expected a keyword to specify option: "
+                                                      option-keywords)
+                                                     stx
+                                                     opt)]))))]
+                     [(def-cname) (cond
+                                   [opt-cname (if (pair? opt-cname)
+                                                  (car opt-cname)
+                                                  opt-cname)]
+                                   [extra-make? #f]
+                                   [else (car (generate-temporaries #'(name)))])]
+                     [(cname) (cond
+                               [opt-cname (if (pair? opt-cname)
+                                              (cons def-cname #'name)
+                                              (cons def-cname def-cname))]
+                               [extra-make? #f]
+                               [else (cons def-cname #'name)])]
+                     [(self-ctr?) (and cname (bound-identifier=? #'name (cdr cname)))])
          (define (add-contracts l)
            (let* ([pred (caddr l)]
                   [ctor-ctc #`(-> ctc ... #,pred)]
@@ -435,20 +502,29 @@
                     (map list (cdddr l) field-ctcs))))
          (cons
           #`(define-syntaxes (name)
-              #,(build-struct-expand-info
-                 #'name (syntax->list #'(field ...))
-                 #f (not mutable?)
-                 #f '(#f) '(#f)
-                 #:omit-constructor? no-ctr?
-                 #:constructor-name (and type-as-ctr? (cons #'name tmp-name))))
+              #,(let ([e (build-struct-expand-info
+                          #'name (syntax->list #'(field ...))
+                          #f (not mutable?)
+                          #f '(#f) '(#f)
+                          #:omit-constructor? no-ctr?
+                          #:constructor-name def-cname)])
+                  (if self-ctr?
+                      #`(make-self-name-struct-info 
+                         (lambda () #,e)
+                         (lambda () (quote-syntax #,def-cname)))
+                      e)))
           (let* ([names (add-contracts
                          (build-struct-names #'name (syntax->list #'(field ...))
                                              #f (not mutable?)
-                                             #:constructor-name (and type-as-ctr? 
-                                                                     (cons #'name tmp-name))))]
+                                             #:constructor-name def-cname))]
                  [cpairs (cons 'contracted
-                               (if no-ctr? (cddr names) (cdr names)))])
-            (list (car names) cpairs))))))
+                               (cond
+                                [no-ctr? (cddr names)]
+                                [else (cdr names)]))]
+                 [l (list (car names) cpairs)])
+            (if self-ctr?
+                (cons #`(define-values-for-export (#,def-cname) name) l)
+                l))))))
     ((_ name fields opt ...)
      (raise-syntax-error #f
                          "bad syntax; expected a parenthesized sequence of fields"
@@ -464,9 +540,9 @@
                          stx))))
 
 (define-signature-form (struct~s/ctc stx)
-  (do-struct~/ctc stx #f))
-(define-signature-form (struct~r/ctc stx)
   (do-struct~/ctc stx #t))
+(define-signature-form (struct~r/ctc stx)
+  (do-struct~/ctc stx #f))
 
 ;; build-val+macro-defs : sig -> (list syntax-object^3)
 (define-for-syntax (build-val+macro-defs sig)

collects/planet/info.ss

@@ -5,4 +5,4 @@
 (define mzscheme-launcher-libraries '("planet.ss"))
 (define scribblings '(("planet.scrbl" (multi-page) (tool))))
 
-(define racket-tools '(("planet" planet/planet "manage Planet package installations" 80)))
+(define raco-commands '(("planet" planet/planet "manage Planet package installations" 80)))

collects/planet/planet.ss

@@ -11,7 +11,7 @@ PLANNED FEATURES:
            (only mzlib/list sort)
            net/url
            mzlib/match
-           tool/command-name
+           raco/command-name
            
            "config.ss"
            "private/planet-shared.ss"

collects/racket/contract/private/blame.ss

@@ -87,8 +87,13 @@
     (pretty-display v port)
     (get-output-string port)))
 
+(define (pretty-format/write v [columns (pretty-print-columns)])
+  (let ([port (open-output-string)])
+    (pretty-write v port)
+    (get-output-string port)))
+
 (define show/display (show pretty-format/display))
-(define show/write (show pretty-format))
+(define show/write (show pretty-format/write))
 
 (define (show-line-break line port len cols)
   (newline port)

collects/racket/contract/private/provide.ss

@@ -533,7 +533,7 @@
                         (loop (cdr l1)
                               (+ i 1)))])))
        
-       ;; get-field-counts/struct-names : syntax syntax -> (listof (cons symbol number))
+       ;; get-field-counts/struct-names : syntax syntax -> (listof (cons number symbol))
        ;; returns a list of numbers corresponding to the numbers of fields for each of the parent structs
        (define (get-field-counts/struct-names struct-name provide-stx)
          (let loop ([parent-info-id struct-name])
@@ -544,7 +544,7 @@
                [(boolean? parent-info) null]
                [else
                 (let ([fields (list-ref parent-info 3)]
-                      [constructor (list-ref parent-info 1)])
+                      [predicate (list-ref parent-info 2)])
                   (cond
                     [(and (not (null? fields))
                           (not (last fields)))
@@ -554,16 +554,16 @@
                       provide-stx
                       struct-name)]
                     [else
-                     (cons (cons (length fields) (constructor->struct-name provide-stx constructor))
+                     (cons (cons (length fields) (predicate->struct-name provide-stx predicate))
                            (loop (list-ref parent-info 5)))]))]))))
        
-       (define (constructor->struct-name orig-stx stx)
+       (define (predicate->struct-name orig-stx stx)
          (and stx
-              (let ([m (regexp-match #rx"^make-(.*)$" (format "~a" (syntax-e stx)))])
+              (let ([m (regexp-match #rx"^(.*)[?]$" (format "~a" (syntax-e stx)))])
                 (cond
                   [m (cadr m)]
                   [else (raise-syntax-error 'contract-base.ss
-                                            "unable to cope with a struct maker whose name doesn't begin with `make-'"
+                                            "unable to cope with a struct supertype whose predicate doesn't end with `?'"
                                             orig-stx)]))))
        
        ;; build-constructor-contract : syntax (listof syntax) syntax -> syntax

collects/racket/gui/init.ss

@@ -1,6 +0,0 @@
-#lang racket
-(require racket/init
-         scheme/gui/base)
-
-(provide (all-from-out racket/init
-                       scheme/gui/base))

collects/racket/gui/lang/reader.ss

@@ -1,2 +1,4 @@
 #lang s-exp syntax/module-reader
 racket/gui
+
+#:language-info '#(racket/language-info get-info #f)

collects/racket/match/parse.ss

@@ -153,6 +153,9 @@
     [(mcons e1 e2) (make-MPair (parse #'e1) (parse #'e2))]
     [(struct s pats)
      (parse-struct stx cert parse #'s #'pats)]
+    [(s . pats)
+     (struct-info? (syntax-local-value #'s (lambda () #f)))
+     (parse-struct stx cert parse #'s #'pats)]
     [(? p q1 qs ...)
      (make-And (cons (make-Pred (cert #'p))
                      (map parse (syntax->list #'(q1 qs ...)))))]

collects/racket/private/define-struct.rkt

@@ -54,7 +54,7 @@
                                        1 0 #f
                                        (list (cons prop:procedure
                                                    (lambda (v stx)
-                                                     (self-ctor-transformer (ref v 0) stx))))
+                                                     (self-ctor-transformer ((ref v 0)) stx))))
                                        (current-inspector) #f '(0))])
       make-))
   (define-values-for-syntax (make-self-ctor-checked-struct-info)
@@ -63,7 +63,7 @@
                                        1 0 #f
                                        (list (cons prop:procedure
                                                    (lambda (v stx)
-                                                     (self-ctor-transformer (ref v 0) stx))))
+                                                     (self-ctor-transformer ((ref v 0)) stx))))
                                        (current-inspector) #f '(0))])
       make-))
 
@@ -203,6 +203,7 @@
                            (#:mutable . #f)
                            (#:guard . #f)
                            (#:constructor-name . #f)
+                           (#:only-constructor? . #f)
                            (#:omit-define-values . #f)
                            (#:omit-define-syntaxes . #f))]
                  [nongen? #f])
@@ -259,14 +260,17 @@
           (loop (cdr p)
                 (extend-config config '#:inspector #'#f)
                 nongen?)]
-         [(eq? '#:constructor-name (syntax-e (car p)))
+         [(or (eq? '#:constructor-name (syntax-e (car p)))
+              (eq? '#:extra-constructor-name (syntax-e (car p))))
           (check-exprs 1 p "identifier")
           (when (lookup config '#:constructor-name)
-            (bad "multiple #:constructor-name keys" (car p)))
+            (bad "multiple #:constructor-name or #:extra-constructor-name keys" (car p)))
           (unless (identifier? (cadr p))
             (bad "need an identifier after #:constructor-name" (cadr p)))
           (loop (cddr p)
-                (extend-config config '#:constructor-name (cadr p))
+                (extend-config (extend-config config '#:constructor-name (cadr p))
+                               '#:only-constructor?
+                               (eq? '#:constructor-name (syntax-e (car p))))
                 nongen?)]
          [(eq? '#:prefab (syntax-e (car p)))
           (when (lookup config '#:inspector)
@@ -360,7 +364,7 @@
                          (car field-stxes))]
                        [else
                         (loop (cdr fields) (cdr field-stxes) #f)]))])
-               (let*-values ([(inspector super-expr props auto-val guard ctor-name mutable?
+               (let*-values ([(inspector super-expr props auto-val guard ctor-name ctor-only? mutable?
                                          omit-define-values? omit-define-syntaxes?)
                               (let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)])
                                 (values (lookup config '#:inspector)
@@ -369,11 +373,13 @@
                                         (lookup config '#:auto-value)
                                         (lookup config '#:guard)
                                         (lookup config '#:constructor-name)
+                                        (lookup config '#:only-constructor?)
                                         (lookup config '#:mutable)
                                         (lookup config '#:omit-define-values)
                                         (lookup config '#:omit-define-syntaxes)))]
                              [(self-ctor?)
-                              (and ctor-name (bound-identifier=? id ctor-name))])
+                              (and ctor-name (bound-identifier=? id ctor-name))]
+                             [(name-as-ctor?) (or self-ctor? (not ctor-only?))])
                  (when mutable?
                    (for-each (lambda (f f-stx)
                                (when (field-mutable? f)
@@ -454,7 +460,7 @@
                                                                          (cons i (loop (add1 i) (cdr fields)))]
                                                                         [else (loop (add1 i) (cdr fields))]))
                                                                   #,guard
-                                                                  '#,ctor-name))])
+                                                                  '#,(if ctor-only? ctor-name id)))])
                                   (values struct: make- ?
                                           #,@(let loop ([i 0][fields fields])
                                                (if (null? fields)
@@ -476,10 +482,10 @@
                                                       #`(quote-syntax #,(prune sel))
                                                       sel)))]
 				  [mk-info (if super-info-checked?
-                                               (if self-ctor?
+                                               (if name-as-ctor?
                                                    #'make-self-ctor-checked-struct-info
                                                    #'make-checked-struct-info)
-                                               (if self-ctor?
+                                               (if name-as-ctor?
                                                    #'make-self-ctor-struct-info
                                                    #'make-struct-info))])
                               (quasisyntax/loc stx
@@ -488,7 +494,9 @@
                                    (lambda ()
                                      (list
                                       (quote-syntax #,(prune struct:))
-                                      (quote-syntax #,(prune make-))
+                                      (quote-syntax #,(prune (if (and ctor-name self-ctor?)
+                                                                 id
+                                                                 make-)))
                                       (quote-syntax #,(prune ?))
                                       (list
                                        #,@(map protect (reverse sels))
@@ -517,8 +525,8 @@
                                             (if super-expr
                                                 #f
                                                 #t))))
-                                   #,@(if self-ctor?
-                                          (list #`(quote-syntax #,make-))
+                                   #,@(if name-as-ctor?
+                                          (list #`(lambda () (quote-syntax #,make-)))
                                           null))))))])
                      (let ([result
                             (cond

collects/racket/private/for.rkt

@@ -22,6 +22,7 @@
              for/last for*/last
              for/hash for*/hash
              for/hasheq for*/hasheq
+             for/hasheqv for*/hasheqv
 
              for/fold/derived for*/fold/derived
 
@@ -328,7 +329,7 @@
       [(hash? v) (:hash-key+val-gen v)]
       [(:sequence? v) (make-sequence who ((:sequence-ref v) v))]
       [else (raise
-             (make-exn:fail:contract
+             (exn:fail:contract
               (format "for: expected a sequence for ~a, got something else: ~v"
                       (if (= 1 (length who))
                           (car who)
@@ -952,6 +953,14 @@
       #`(let-values ([(key val) #,x])
           (hash-set table key val))))
 
+  (define-for-variants (for/hasheqv for*/hasheqv)
+    ([table #hasheqv()])
+    (lambda (x) x)
+    (lambda (rhs) rhs)
+    (lambda (x)
+      #`(let-values ([(key val) #,x])
+          (hash-set table key val))))
+
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;  specific sequences
 

collects/racket/private/kernstruct.rkt

@@ -6,266 +6,438 @@
   (#%require "define.rkt")
   (#%require (for-syntax "struct-info.rkt"))
   (#%provide (all-defined))
-  (define-syntax exn
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn)
-        (quote-syntax make-exn)
-        (quote-syntax exn?)
-        (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message))
-        '(#f #f)
-        #t))))
-  (define-syntax exn:fail
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail)
-        (quote-syntax make-exn:fail)
-        (quote-syntax exn:fail?)
-        (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message))
-        '(#f #f)
-        (quote-syntax exn)))))
-  (define-syntax exn:fail:contract
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:contract)
-        (quote-syntax make-exn:fail:contract)
-        (quote-syntax exn:fail:contract?)
-        (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message))
-        '(#f #f)
-        (quote-syntax exn:fail)))))
-  (define-syntax exn:fail:contract:arity
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:contract:arity)
-        (quote-syntax make-exn:fail:contract:arity)
-        (quote-syntax exn:fail:contract:arity?)
-        (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message))
-        '(#f #f)
-        (quote-syntax exn:fail:contract)))))
-  (define-syntax exn:fail:contract:divide-by-zero
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:contract:divide-by-zero)
-        (quote-syntax make-exn:fail:contract:divide-by-zero)
-        (quote-syntax exn:fail:contract:divide-by-zero?)
-        (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message))
-        '(#f #f)
-        (quote-syntax exn:fail:contract)))))
-  (define-syntax exn:fail:contract:non-fixnum-result
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:contract:non-fixnum-result)
-        (quote-syntax make-exn:fail:contract:non-fixnum-result)
-        (quote-syntax exn:fail:contract:non-fixnum-result?)
-        (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message))
-        '(#f #f)
-        (quote-syntax exn:fail:contract)))))
-  (define-syntax exn:fail:contract:continuation
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:contract:continuation)
-        (quote-syntax make-exn:fail:contract:continuation)
-        (quote-syntax exn:fail:contract:continuation?)
-        (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message))
-        '(#f #f)
-        (quote-syntax exn:fail:contract)))))
-  (define-syntax exn:fail:contract:variable
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:contract:variable)
-        (quote-syntax make-exn:fail:contract:variable)
-        (quote-syntax exn:fail:contract:variable?)
-        (list
-         (quote-syntax exn:fail:contract:variable-id)
-         (quote-syntax exn-continuation-marks)
-         (quote-syntax exn-message))
-        '(#f #f #f)
-        (quote-syntax exn:fail:contract)))))
-  (define-syntax exn:fail:syntax
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:syntax)
-        (quote-syntax make-exn:fail:syntax)
-        (quote-syntax exn:fail:syntax?)
-        (list
-         (quote-syntax exn:fail:syntax-exprs)
-         (quote-syntax exn-continuation-marks)
-         (quote-syntax exn-message))
-        '(#f #f #f)
-        (quote-syntax exn:fail)))))
-  (define-syntax exn:fail:read
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:read)
-        (quote-syntax make-exn:fail:read)
-        (quote-syntax exn:fail:read?)
-        (list
-         (quote-syntax exn:fail:read-srclocs)
-         (quote-syntax exn-continuation-marks)
-         (quote-syntax exn-message))
-        '(#f #f #f)
-        (quote-syntax exn:fail)))))
-  (define-syntax exn:fail:read:eof
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:read:eof)
-        (quote-syntax make-exn:fail:read:eof)
-        (quote-syntax exn:fail:read:eof?)
-        (list
-         (quote-syntax exn:fail:read-srclocs)
-         (quote-syntax exn-continuation-marks)
-         (quote-syntax exn-message))
-        '(#f #f #f)
-        (quote-syntax exn:fail:read)))))
-  (define-syntax exn:fail:read:non-char
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:read:non-char)
-        (quote-syntax make-exn:fail:read:non-char)
-        (quote-syntax exn:fail:read:non-char?)
-        (list
-         (quote-syntax exn:fail:read-srclocs)
-         (quote-syntax exn-continuation-marks)
-         (quote-syntax exn-message))
-        '(#f #f #f)
-        (quote-syntax exn:fail:read)))))
-  (define-syntax exn:fail:filesystem
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:filesystem)
-        (quote-syntax make-exn:fail:filesystem)
-        (quote-syntax exn:fail:filesystem?)
-        (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message))
-        '(#f #f)
-        (quote-syntax exn:fail)))))
-  (define-syntax exn:fail:filesystem:exists
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:filesystem:exists)
-        (quote-syntax make-exn:fail:filesystem:exists)
-        (quote-syntax exn:fail:filesystem:exists?)
-        (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message))
-        '(#f #f)
-        (quote-syntax exn:fail:filesystem)))))
-  (define-syntax exn:fail:filesystem:version
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:filesystem:version)
-        (quote-syntax make-exn:fail:filesystem:version)
-        (quote-syntax exn:fail:filesystem:version?)
-        (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message))
-        '(#f #f)
-        (quote-syntax exn:fail:filesystem)))))
-  (define-syntax exn:fail:network
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:network)
-        (quote-syntax make-exn:fail:network)
-        (quote-syntax exn:fail:network?)
-        (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message))
-        '(#f #f)
-        (quote-syntax exn:fail)))))
-  (define-syntax exn:fail:out-of-memory
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:out-of-memory)
-        (quote-syntax make-exn:fail:out-of-memory)
-        (quote-syntax exn:fail:out-of-memory?)
-        (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message))
-        '(#f #f)
-        (quote-syntax exn:fail)))))
-  (define-syntax exn:fail:unsupported
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:unsupported)
-        (quote-syntax make-exn:fail:unsupported)
-        (quote-syntax exn:fail:unsupported?)
-        (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message))
-        '(#f #f)
-        (quote-syntax exn:fail)))))
-  (define-syntax exn:fail:user
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:fail:user)
-        (quote-syntax make-exn:fail:user)
-        (quote-syntax exn:fail:user?)
-        (list (quote-syntax exn-continuation-marks) (quote-syntax exn-message))
-        '(#f #f)
-        (quote-syntax exn:fail)))))
-  (define-syntax exn:break
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:exn:break)
-        (quote-syntax make-exn:break)
-        (quote-syntax exn:break?)
-        (list
-         (quote-syntax exn:break-continuation)
-         (quote-syntax exn-continuation-marks)
-         (quote-syntax exn-message))
-        '(#f #f #f)
-        (quote-syntax exn)))))
-  (define-syntax arity-at-least
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:arity-at-least)
-        (quote-syntax make-arity-at-least)
-        (quote-syntax arity-at-least?)
-        (list (quote-syntax arity-at-least-value))
-        '(#f)
-        #t))))
-  (define-syntax date
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:date)
-        (quote-syntax make-date)
-        (quote-syntax date?)
-        (list
-         (quote-syntax date-time-zone-offset)
-         (quote-syntax date-dst?)
-         (quote-syntax date-year-day)
-         (quote-syntax date-week-day)
-         (quote-syntax date-year)
-         (quote-syntax date-month)
-         (quote-syntax date-day)
-         (quote-syntax date-hour)
-         (quote-syntax date-minute)
-         (quote-syntax date-second))
-        '(#f #f #f #f #f #f #f #f #f #f)
-        #t))))
-  (define-syntax srcloc
-    (make-struct-info
-     (λ ()
-       (list
-        (quote-syntax struct:srcloc)
-        (quote-syntax make-srcloc)
-        (quote-syntax srcloc?)
-        (list
-         (quote-syntax srcloc-span)
-         (quote-syntax srcloc-position)
-         (quote-syntax srcloc-column)
-         (quote-syntax srcloc-line)
-         (quote-syntax srcloc-source))
-        '(#f #f #f #f #f)
-        #t)))))
+  (define-values-for-syntax
+   (make-self-ctr-struct-info)
+   (letrec-values (((struct: make- ? ref set!)
+                    (make-struct-type
+                     'self-ctor-struct-info
+                     struct:struct-info
+                     1
+                     0
+                     #f
+                     (list
+                      (cons
+                       prop:procedure
+                       (lambda (v stx)
+                         (let-values (((id) ((ref v 0))))
+                           (if (symbol? (syntax-e stx))
+                             id
+                             (datum->syntax
+                              stx
+                              (cons id (cdr (syntax-e stx)))
+                              stx
+                              stx))))))
+                     (current-inspector)
+                     #f
+                     '(0))))
+     make-))
+  (begin
+    (#%require (rename '#%kernel kernel:exn exn))
+    (define make-exn kernel:exn)
+    (define-syntax exn
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn)
+          (quote-syntax make-exn)
+          (quote-syntax exn?)
+          (list
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f)
+          #t))
+       (λ () (quote-syntax kernel:exn)))))
+  (begin
+    (#%require (rename '#%kernel kernel:exn:fail exn:fail))
+    (define make-exn:fail kernel:exn:fail)
+    (define-syntax exn:fail
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail)
+          (quote-syntax make-exn:fail)
+          (quote-syntax exn:fail?)
+          (list
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f)
+          (quote-syntax exn)))
+       (λ () (quote-syntax kernel:exn:fail)))))
+  (begin
+    (#%require (rename '#%kernel kernel:exn:fail:contract exn:fail:contract))
+    (define make-exn:fail:contract kernel:exn:fail:contract)
+    (define-syntax exn:fail:contract
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:contract)
+          (quote-syntax make-exn:fail:contract)
+          (quote-syntax exn:fail:contract?)
+          (list
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f)
+          (quote-syntax exn:fail)))
+       (λ () (quote-syntax kernel:exn:fail:contract)))))
+  (begin
+    (#%require
+     (rename '#%kernel kernel:exn:fail:contract:arity exn:fail:contract:arity))
+    (define make-exn:fail:contract:arity kernel:exn:fail:contract:arity)
+    (define-syntax exn:fail:contract:arity
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:contract:arity)
+          (quote-syntax make-exn:fail:contract:arity)
+          (quote-syntax exn:fail:contract:arity?)
+          (list
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f)
+          (quote-syntax exn:fail:contract)))
+       (λ () (quote-syntax kernel:exn:fail:contract:arity)))))
+  (begin
+    (#%require
+     (rename '#%kernel
+             kernel:exn:fail:contract:divide-by-zero
+             exn:fail:contract:divide-by-zero))
+    (define make-exn:fail:contract:divide-by-zero
+      kernel:exn:fail:contract:divide-by-zero)
+    (define-syntax exn:fail:contract:divide-by-zero
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:contract:divide-by-zero)
+          (quote-syntax make-exn:fail:contract:divide-by-zero)
+          (quote-syntax exn:fail:contract:divide-by-zero?)
+          (list
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f)
+          (quote-syntax exn:fail:contract)))
+       (λ () (quote-syntax kernel:exn:fail:contract:divide-by-zero)))))
+  (begin
+    (#%require
+     (rename '#%kernel
+             kernel:exn:fail:contract:non-fixnum-result
+             exn:fail:contract:non-fixnum-result))
+    (define make-exn:fail:contract:non-fixnum-result
+      kernel:exn:fail:contract:non-fixnum-result)
+    (define-syntax exn:fail:contract:non-fixnum-result
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:contract:non-fixnum-result)
+          (quote-syntax make-exn:fail:contract:non-fixnum-result)
+          (quote-syntax exn:fail:contract:non-fixnum-result?)
+          (list
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f)
+          (quote-syntax exn:fail:contract)))
+       (λ () (quote-syntax kernel:exn:fail:contract:non-fixnum-result)))))
+  (begin
+    (#%require
+     (rename '#%kernel
+             kernel:exn:fail:contract:continuation
+             exn:fail:contract:continuation))
+    (define make-exn:fail:contract:continuation
+      kernel:exn:fail:contract:continuation)
+    (define-syntax exn:fail:contract:continuation
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:contract:continuation)
+          (quote-syntax make-exn:fail:contract:continuation)
+          (quote-syntax exn:fail:contract:continuation?)
+          (list
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f)
+          (quote-syntax exn:fail:contract)))
+       (λ () (quote-syntax kernel:exn:fail:contract:continuation)))))
+  (begin
+    (#%require
+     (rename '#%kernel
+             kernel:exn:fail:contract:variable
+             exn:fail:contract:variable))
+    (define make-exn:fail:contract:variable kernel:exn:fail:contract:variable)
+    (define-syntax exn:fail:contract:variable
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:contract:variable)
+          (quote-syntax make-exn:fail:contract:variable)
+          (quote-syntax exn:fail:contract:variable?)
+          (list
+           (quote-syntax exn:fail:contract:variable-id)
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f #f)
+          (quote-syntax exn:fail:contract)))
+       (λ () (quote-syntax kernel:exn:fail:contract:variable)))))
+  (begin
+    (#%require (rename '#%kernel kernel:exn:fail:syntax exn:fail:syntax))
+    (define make-exn:fail:syntax kernel:exn:fail:syntax)
+    (define-syntax exn:fail:syntax
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:syntax)
+          (quote-syntax make-exn:fail:syntax)
+          (quote-syntax exn:fail:syntax?)
+          (list
+           (quote-syntax exn:fail:syntax-exprs)
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f #f)
+          (quote-syntax exn:fail)))
+       (λ () (quote-syntax kernel:exn:fail:syntax)))))
+  (begin
+    (#%require (rename '#%kernel kernel:exn:fail:read exn:fail:read))
+    (define make-exn:fail:read kernel:exn:fail:read)
+    (define-syntax exn:fail:read
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:read)
+          (quote-syntax make-exn:fail:read)
+          (quote-syntax exn:fail:read?)
+          (list
+           (quote-syntax exn:fail:read-srclocs)
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f #f)
+          (quote-syntax exn:fail)))
+       (λ () (quote-syntax kernel:exn:fail:read)))))
+  (begin
+    (#%require (rename '#%kernel kernel:exn:fail:read:eof exn:fail:read:eof))
+    (define make-exn:fail:read:eof kernel:exn:fail:read:eof)
+    (define-syntax exn:fail:read:eof
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:read:eof)
+          (quote-syntax make-exn:fail:read:eof)
+          (quote-syntax exn:fail:read:eof?)
+          (list
+           (quote-syntax exn:fail:read-srclocs)
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f #f)
+          (quote-syntax exn:fail:read)))
+       (λ () (quote-syntax kernel:exn:fail:read:eof)))))
+  (begin
+    (#%require
+     (rename '#%kernel kernel:exn:fail:read:non-char exn:fail:read:non-char))
+    (define make-exn:fail:read:non-char kernel:exn:fail:read:non-char)
+    (define-syntax exn:fail:read:non-char
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:read:non-char)
+          (quote-syntax make-exn:fail:read:non-char)
+          (quote-syntax exn:fail:read:non-char?)
+          (list
+           (quote-syntax exn:fail:read-srclocs)
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f #f)
+          (quote-syntax exn:fail:read)))
+       (λ () (quote-syntax kernel:exn:fail:read:non-char)))))
+  (begin
+    (#%require
+     (rename '#%kernel kernel:exn:fail:filesystem exn:fail:filesystem))
+    (define make-exn:fail:filesystem kernel:exn:fail:filesystem)
+    (define-syntax exn:fail:filesystem
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:filesystem)
+          (quote-syntax make-exn:fail:filesystem)
+          (quote-syntax exn:fail:filesystem?)
+          (list
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f)
+          (quote-syntax exn:fail)))
+       (λ () (quote-syntax kernel:exn:fail:filesystem)))))
+  (begin
+    (#%require
+     (rename '#%kernel
+             kernel:exn:fail:filesystem:exists
+             exn:fail:filesystem:exists))
+    (define make-exn:fail:filesystem:exists kernel:exn:fail:filesystem:exists)
+    (define-syntax exn:fail:filesystem:exists
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:filesystem:exists)
+          (quote-syntax make-exn:fail:filesystem:exists)
+          (quote-syntax exn:fail:filesystem:exists?)
+          (list
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f)
+          (quote-syntax exn:fail:filesystem)))
+       (λ () (quote-syntax kernel:exn:fail:filesystem:exists)))))
+  (begin
+    (#%require
+     (rename '#%kernel
+             kernel:exn:fail:filesystem:version
+             exn:fail:filesystem:version))
+    (define make-exn:fail:filesystem:version
+      kernel:exn:fail:filesystem:version)
+    (define-syntax exn:fail:filesystem:version
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:filesystem:version)
+          (quote-syntax make-exn:fail:filesystem:version)
+          (quote-syntax exn:fail:filesystem:version?)
+          (list
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f)
+          (quote-syntax exn:fail:filesystem)))
+       (λ () (quote-syntax kernel:exn:fail:filesystem:version)))))
+  (begin
+    (#%require (rename '#%kernel kernel:exn:fail:network exn:fail:network))
+    (define make-exn:fail:network kernel:exn:fail:network)
+    (define-syntax exn:fail:network
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:network)
+          (quote-syntax make-exn:fail:network)
+          (quote-syntax exn:fail:network?)
+          (list
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f)
+          (quote-syntax exn:fail)))
+       (λ () (quote-syntax kernel:exn:fail:network)))))
+  (begin
+    (#%require
+     (rename '#%kernel kernel:exn:fail:out-of-memory exn:fail:out-of-memory))
+    (define make-exn:fail:out-of-memory kernel:exn:fail:out-of-memory)
+    (define-syntax exn:fail:out-of-memory
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:out-of-memory)
+          (quote-syntax make-exn:fail:out-of-memory)
+          (quote-syntax exn:fail:out-of-memory?)
+          (list
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f)
+          (quote-syntax exn:fail)))
+       (λ () (quote-syntax kernel:exn:fail:out-of-memory)))))
+  (begin
+    (#%require
+     (rename '#%kernel kernel:exn:fail:unsupported exn:fail:unsupported))
+    (define make-exn:fail:unsupported kernel:exn:fail:unsupported)
+    (define-syntax exn:fail:unsupported
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:unsupported)
+          (quote-syntax make-exn:fail:unsupported)
+          (quote-syntax exn:fail:unsupported?)
+          (list
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f)
+          (quote-syntax exn:fail)))
+       (λ () (quote-syntax kernel:exn:fail:unsupported)))))
+  (begin
+    (#%require (rename '#%kernel kernel:exn:fail:user exn:fail:user))
+    (define make-exn:fail:user kernel:exn:fail:user)
+    (define-syntax exn:fail:user
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:fail:user)
+          (quote-syntax make-exn:fail:user)
+          (quote-syntax exn:fail:user?)
+          (list
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f)
+          (quote-syntax exn:fail)))
+       (λ () (quote-syntax kernel:exn:fail:user)))))
+  (begin
+    (#%require (rename '#%kernel kernel:exn:break exn:break))
+    (define make-exn:break kernel:exn:break)
+    (define-syntax exn:break
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:exn:break)
+          (quote-syntax make-exn:break)
+          (quote-syntax exn:break?)
+          (list
+           (quote-syntax exn:break-continuation)
+           (quote-syntax exn-continuation-marks)
+           (quote-syntax exn-message))
+          '(#f #f #f)
+          (quote-syntax exn)))
+       (λ () (quote-syntax kernel:exn:break)))))
+  (begin
+    (#%require (rename '#%kernel kernel:arity-at-least arity-at-least))
+    (define make-arity-at-least kernel:arity-at-least)
+    (define-syntax arity-at-least
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:arity-at-least)
+          (quote-syntax make-arity-at-least)
+          (quote-syntax arity-at-least?)
+          (list (quote-syntax arity-at-least-value))
+          '(#f)
+          #t))
+       (λ () (quote-syntax kernel:arity-at-least)))))
+  (begin
+    (#%require (rename '#%kernel kernel:date date))
+    (define make-date kernel:date)
+    (define-syntax date
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:date)
+          (quote-syntax make-date)
+          (quote-syntax date?)
+          (list
+           (quote-syntax date-time-zone-offset)
+           (quote-syntax date-dst?)
+           (quote-syntax date-year-day)
+           (quote-syntax date-week-day)
+           (quote-syntax date-year)
+           (quote-syntax date-month)
+           (quote-syntax date-day)
+           (quote-syntax date-hour)
+           (quote-syntax date-minute)
+           (quote-syntax date-second))
+          '(#f #f #f #f #f #f #f #f #f #f)
+          #t))
+       (λ () (quote-syntax kernel:date)))))
+  (begin
+    (#%require (rename '#%kernel kernel:srcloc srcloc))
+    (define make-srcloc kernel:srcloc)
+    (define-syntax srcloc
+      (make-self-ctr-struct-info
+       (λ ()
+         (list
+          (quote-syntax struct:srcloc)
+          (quote-syntax make-srcloc)
+          (quote-syntax srcloc?)
+          (list
+           (quote-syntax srcloc-span)
+           (quote-syntax srcloc-position)
+           (quote-syntax srcloc-column)
+           (quote-syntax srcloc-line)
+           (quote-syntax srcloc-source))
+          '(#f #f #f #f #f)
+          #t))
+       (λ () (quote-syntax kernel:srcloc))))))

collects/racket/private/kw.rkt

@@ -948,7 +948,7 @@
                                                  (object-name p)
                                                  p))])
                   (raise
-                   (make-exn:fail:contract
+                   (exn:fail:contract
                     (if extra-kw
                         (if (keyword-procedure? p)
                             (format
@@ -1028,7 +1028,7 @@
                                 (cond
                                  [(integer? a) (+ a delta)]
                                  [(arity-at-least? a)
-                                  (make-arity-at-least (+ (arity-at-least-value a) delta))]
+                                  (arity-at-least (+ (arity-at-least-value a) delta))]
                                  [else
                                   (map loop a)])))]
                  [new-arity (inc-arity arity 2)]

collects/racket/private/misc.rkt

@@ -99,7 +99,7 @@
       (let-values ([(base name dir?) (split-path n)])
 	(if dir?
 	    (raise
-	     (make-exn:fail:filesystem
+	     (exn:fail:filesystem
 	      (string->immutable-string
 	       (format "load/cd: cannot open a directory: ~s" n))
 	      (current-continuation-marks)))
@@ -108,7 +108,7 @@
 		(begin
 		  (if (not (directory-exists? base))
 		      (raise
-		       (make-exn:fail:filesystem
+		       (exn:fail:filesystem
 			(string->immutable-string
 			 (format 
 			  "load/cd: directory of ~s does not exist (current directory is ~s)" 

collects/racket/private/more-scheme.rkt

@@ -367,9 +367,10 @@
     (let* ([not-there (gensym)]
            [up (lambda (who mut? set ht key xform default)
                  (unless (and (hash? ht)
-                              (or (not mut?)
-                                  (not (immutable? ht))))
-                   (raise-type-error who (if mut? "mutable hash" "hash") ht))
+                              (if mut?
+                                  (not (immutable? ht))
+                                  (immutable? ht)))
+                   (raise-type-error who (if mut? "mutable hash table" "immutable hash table") ht))
                  (unless (and (procedure? xform)
                               (procedure-arity-includes? xform 1))
                    (raise-type-error who "procedure (arity 1)" xform))
@@ -391,9 +392,14 @@
                (hash-update! ht key xform not-there)])]
             [hash-has-key?
              (lambda (ht key)
+               (unless (hash? ht)
+                 (raise-type-error 'hash-has-key? "hash table" 0 ht key))
                (not (eq? not-there (hash-ref ht key not-there))))]
             [hash-ref!
              (lambda (ht key new)
+               (unless (and (hash? ht)
+                            (not (immutable? ht)))
+                 (raise-type-error 'hash-ref! "mutable hash table" 0 ht key new))
                (let ([v (hash-ref ht key not-there)])
                  (if (eq? not-there v)
                    (let ([n (if (procedure? new) (new) new)])

collects/racket/private/namespace.rkt

@@ -19,14 +19,14 @@
            [ns (parameterize ([current-namespace this-ns]) ; ensures correct phase
                  (make-empty-namespace))])
       (namespace-attach-module this-ns
-                               'scheme/base 
+                               'racket/base 
                                ns)
       ns))
 
   (define (make-base-namespace)
     (let ([ns (make-base-empty-namespace)])
       (parameterize ([current-namespace ns])
-        (namespace-require 'scheme/base))
+        (namespace-require 'racket/base))
       ns))
 
   ;; ----------------------------------------

collects/racket/private/struct.rkt

@@ -14,6 +14,7 @@
       (cond
        [(syntax? config) (config-has-name? (syntax-e config))]
        [(pair? config) (or (eq? (syntax-e (car config)) '#:constructor-name)
+                           (eq? (syntax-e (car config)) '#:extra-constructor-name)
                            (config-has-name? (cdr config)))]
        [else #f]))
     (with-syntax ([orig stx])

collects/racket/runtime-config.rkt

@@ -4,7 +4,4 @@
 
   (define-values (configure)
     (lambda (config)
-      (current-prompt-read  (lambda ()
-                              (printf "> ")
-                              (read)))
       (print-as-quasiquote #t))))

collects/racket/sandbox.rkt

@@ -1,11 +1,11 @@
-#lang scheme/base
+#lang racket/base
 
-(require scheme/port
-         scheme/path
-         scheme/list
-         scheme/string
+(require racket/port
+         racket/path
+         racket/list
+         racket/string
          syntax/moddep
-         scheme/gui/dynamic
+         racket/gui/dynamic
          planet/config)
 
 (provide gui?
@@ -53,7 +53,7 @@
 
 (define gui? (gui-available?))
 
-(define-syntax mz/mr ; use a value for mzscheme, or pull a mred binding
+(define-syntax mz/mr ; use a value for mzracket, or pull a mred binding
   (syntax-rules ()
     [(mz/mr mzval mrsym)
      (if gui? (gui-dynamic-require 'mrsym) mzval)]))
@@ -479,8 +479,8 @@
          ;; needed to make the test-engine work
          (let ([orig-ns (namespace-anchor->empty-namespace anchor)])
            (parameterize ([current-namespace orig-ns])
-             (dynamic-require 'scheme/class #f))
-           (namespace-attach-module orig-ns 'scheme/class))]))
+             (dynamic-require 'racket/class #f))
+           (namespace-attach-module orig-ns 'racket/class))]))
 
 ;; Returns a single (module ...) or (begin ...) expression (a `begin' list
 ;; will be evaluated one by one -- the language might not have a `begin').
@@ -490,7 +490,7 @@
 ;; A more general solution would be to create a new module that exports
 ;; the given language plus all of the given extra requires.
 ;;
-;; We use `#%requre' because, unlike the `require' of scheme/base,
+;; We use `#%requre' because, unlike the `require' of racket/base,
 ;; it comes from `#%kernel', so it's always present through
 ;; transitive requires.
 (define (build-program language requires input-program)
@@ -882,7 +882,7 @@
        (if (eq? h default-sandbox-exit-handler)
          (lambda _ (terminate+kill! 'exited #f))
          h))]
-    ;; Note the above definition of `current-eventspace': in MzScheme, it
+    ;; Note the above definition of `current-eventspace': in Racket, it
     ;; is an unused parameter.  Also note that creating an eventspace
     ;; starts a thread that will eventually run the callback code (which
     ;; evaluates the program in `run-in-bg') -- so this parameterization

collects/racket/set.rkt

@@ -6,8 +6,11 @@
          set-empty? set-count
          set-member? set-add set-remove
          set-union set-intersect set-subtract
+         subset?
          set-map set-for-each 
-         (rename-out [*in-set in-set]))
+         (rename-out [*in-set in-set])
+         for/set for/seteq for/seteqv
+         for*/set for*/seteq for*/seteqv)
 
 (define-struct set (ht)
   #:omit-define-syntaxes
@@ -161,6 +164,18 @@
     (for/fold ([set set]) ([set2 (in-list sets)])
       (set-subtract set set2))]))
 
+(define (subset? set2 set1)
+  (unless (set? set2) (raise-type-error 'subset? "set" 0 set2 set1))
+  (unless (set? set1) (raise-type-error 'subset? "set" 0 set2 set1))
+  (let ([ht1 (set-ht set1)]
+        [ht2 (set-ht set2)])
+    (unless (and (eq? (hash-eq? ht1) (hash-eq? ht2))
+                 (eq? (hash-eqv? ht1) (hash-eqv? ht2)))
+      (raise-mismatch-error 'set-subset? "second set's equivalence predicate is not the same as the first set: "
+                            set2))
+    (for/and ([v (in-hash-keys ht2)])
+      (hash-ref ht1 v #f))))
+
 (define (set-map set proc)
   (unless (set? set) (raise-type-error 'set-map "set" 0 set proc))
   (unless (and (procedure? proc)
@@ -206,3 +221,17 @@
            #t
            ;; loop args
            ((hash-iterate-next ht pos)))]])))
+
+(define-syntax-rule (define-for for/fold/derived for/set set)
+  (define-syntax (for/set stx)
+    (syntax-case stx ()
+      [(_ bindings . body)
+       (quasisyntax/loc stx
+         (for/fold/derived #,stx ([s (set)]) bindings (set-add s (let () . body))))])))
+
+(define-for for/fold/derived for/set set)
+(define-for for*/fold/derived for*/set set)
+(define-for for/fold/derived for/seteq seteq)
+(define-for for*/fold/derived for*/seteq seteq)
+(define-for for/fold/derived for/seteqv seteqv)
+(define-for for*/fold/derived for*/seteqv seteqv)

collects/racket/signature/lang/reader.ss

@@ -0,0 +1,2 @@
+#lang s-exp syntax/module-reader
+racket/signature/lang

collects/racket/unit.rkt

@@ -5,6 +5,7 @@
            (for-syntax racket/base
                        syntax/struct))
   (provide (except-out (all-from-out mzlib/unit)
-                       struct struct/ctc
-                       struct~r struct~r/ctc
-                       struct~s struct~s/ctc)))
+                        struct struct/ctc
+                        struct~r struct~r/ctc
+                        struct~s struct~s/ctc)
+           (rename-out [struct~r/ctc struct/ctc])))

collects/racket/unit/lang/reader.ss

@@ -0,0 +1,2 @@
+#lang s-exp syntax/module-reader
+racket/unit/lang

collects/raco/all-tools.ss

@@ -4,11 +4,11 @@
 (provide all-tools)
 
 (define (all-tools)
-  (let* ([dirs (find-relevant-directories '(racket-tools))]
+  (let* ([dirs (find-relevant-directories '(raco-commands))]
          [tools (make-hash)])
     (for ([i (in-list (map get-info/full dirs))]
           [d (in-list dirs)])
-      (let ([entries (let ([l (i 'racket-tools (lambda () null))])
+      (let ([entries (let ([l (i 'raco-commands (lambda () null))])
                        (if (list? l)
                            l
                            (list l)))])
@@ -33,7 +33,7 @@
            [else
             (fprintf
              (current-error-port)
-             "warning: ~s provided bad `racket-tools' spec: ~e"
+             "warning: ~s provided bad `raco-commands' spec: ~e"
              d
              entry)]))))
     tools))