diff --git a/collects/scribble/private/manual-form.rkt b/collects/scribble/private/manual-form.rkt
index e793daed..3628ca86 100644
--- a/collects/scribble/private/manual-form.rkt
+++ b/collects/scribble/private/manual-form.rkt
@@ -10,7 +10,9 @@
          "manual-scheme.rkt"
          "manual-bind.rkt"
          scheme/list
-         (for-syntax scheme/base)
+         (for-syntax scheme/base
+                     syntax/parse
+                     racket/syntax)
          (for-label scheme/base))
 
 (provide defform defform* defform/subs defform*/subs defform/none
@@ -24,226 +26,123 @@
                      [racketgrammar* schemegrammar*])
          var svar)
 
+(begin-for-syntax
+ (define-splicing-syntax-class kind-kw
+   #:description "#:kind keyword"
+   (pattern (~optional (~seq #:kind kind)
+                       #:defaults ([kind #'#f]))))
+   
+ (define-splicing-syntax-class id-kw
+   #:description "#:id keyword"
+   (pattern (~seq #:id [defined-id:id defined-id-expr]))
+   (pattern (~seq #:id defined-id:id)
+            #:with defined-id-expr #'(quote-syntax defined-id))
+   (pattern (~seq #:id [#f #f])
+            #:with defined-id #'#f
+            #:with defined-id-expr #'#f)
+   (pattern (~seq)
+            #:with defined-id #'#f
+            #:with defined-id-expr #'#f))
+ 
+ (define-splicing-syntax-class literals-kw
+   #:description "#:literals keyword"
+   (pattern (~optional (~seq #:literals (lit:id ...))
+                       #:defaults ([(lit 1) '()]))))
+
+ (define-splicing-syntax-class contracts-kw
+   #:description "#:contracts keyword"
+   (pattern (~optional (~seq #:contracts ([contract-nonterm:id contract-expr] ...))
+                       #:defaults ([(contract-nonterm 1) '()]
+                                   [(contract-expr 1) '()]))))
+
+ (define-syntax-class grammar
+   (pattern ([non-term-id:id non-term-form ...] ...)))
+ )
+
 (define-syntax (defform*/subs stx)
-  (syntax-case stx ()
-    [(_ #:kind kind #:id defined-id #:literals (lit ...) [spec spec1 ...]
-        ([non-term-id non-term-form ...] ...)
-        #:contracts ([contract-nonterm contract-expr] ...)
+  (syntax-parse stx
+    [(_ k:kind-kw d:id-kw l:literals-kw [spec spec1 ...]
+        g:grammar
+        c:contracts-kw
         desc ...)
-     (with-syntax ([(defined-id defined-id-expr)
-                    (if (identifier? #'defined-id)
-                        (syntax [defined-id (quote-syntax defined-id)])
-                        #'defined-id)])
-       (with-syntax ([new-spec
-                      (let loop ([spec #'spec])
-                        (if (and (identifier? spec)
-                                 (free-identifier=? spec #'defined-id))
-                            (datum->syntax #'here '(unsyntax x) spec spec)
-                            (syntax-case spec ()
-                              [(a . b)
-                               (datum->syntax spec
-                                              (cons (loop #'a) (loop #'b))
-                                              spec
-                                              spec)]
-                              [_ spec])))])
-         (for-each (lambda (id)
-                     (unless (identifier? id)
-                       (raise-syntax-error #f
-                                           "expected an identifier for a literal"
-                                           stx
-                                           id)))
-                   (syntax->list #'(lit ...)))
+     (with-syntax* ([defined-id (if (syntax-e #'d.defined-id)
+                                    #'d.defined-id
+                                    (syntax-case #'spec ()
+                                      [(spec-id . _) #'spec-id]))]
+                    [defined-id-expr (if (syntax-e #'d.defined-id-expr)
+                                         #'d.defined-id-expr
+                                         #'(quote-syntax defined-id))]
+                    [new-spec
+                     (let loop ([spec #'spec])
+                       (if (and (identifier? spec)
+                                (free-identifier=? spec #'defined-id))
+                           (datum->syntax #'here '(unsyntax x) spec spec)
+                           (syntax-case spec ()
+                             [(a . b)
+                              (datum->syntax spec
+                                             (cons (loop #'a) (loop #'b))
+                                             spec
+                                             spec)]
+                             [_ spec])))])
          #'(with-togetherable-racket-variables
-            (lit ...)
+            (l.lit ...)
             ([form [defined-id spec]] [form [defined-id spec1]] ...
-             [non-term (non-term-id non-term-form ...)] ...)
-            (*defforms kind defined-id-expr
+             [non-term (g.non-term-id g.non-term-form ...)] ...)
+            (*defforms k.kind defined-id-expr
                        '(spec spec1 ...)
                        (list (lambda (x) (racketblock0/form new-spec))
                              (lambda (ignored) (racketblock0/form spec1)) ...)
-                       '((non-term-id non-term-form ...) ...)
-                       (list (list (lambda () (racket non-term-id))
-                                   (lambda () (racketblock0/form non-term-form))
+                       '((g.non-term-id g.non-term-form ...) ...)
+                       (list (list (lambda () (racket g.non-term-id))
+                                   (lambda () (racketblock0/form g.non-term-form))
                                    ...)
                              ...)
-                       (list (list (lambda () (racket contract-nonterm))
-                                   (lambda () (racketblock0 contract-expr)))
+                       (list (list (lambda () (racket c.contract-nonterm))
+                                   (lambda () (racketblock0 c.contract-expr)))
                              ...)
-                       (lambda () (list desc ...))))))]
-    [(fm #:id defined-id #:literals (lit ...) [spec spec1 ...]
-         ([non-term-id non-term-form ...] ...)
-         #:contracts ([contract-nonterm contract-expr] ...)
-         desc ...)
-     (syntax/loc stx
-       (fm #:kind #f #:id defined-id #:literals (lit ...) [spec spec1 ...]
-           ([non-term-id non-term-form ...] ...)
-           #:contracts ([contract-nonterm contract-expr] ...)
-           desc ...))]
-    [(fm #:id defined-id #:literals (lit ...) [spec spec1 ...]
-         ([non-term-id non-term-form ...] ...)
-         desc ...)
-     (syntax/loc stx
-       (fm #:id defined-id #:literals (lit ...) [spec spec1 ...]
-           ([non-term-id non-term-form ...] ...)
-           #:contracts ()
-           desc ...))]
-    [(fm #:kind kind #:id defined-id #:literals (lit ...) [spec spec1 ...]
-         ([non-term-id non-term-form ...] ...)
-         desc ...)
-     (syntax/loc stx
-       (fm #:kind kind #:id defined-id #:literals (lit ...) [spec spec1 ...]
-           ([non-term-id non-term-form ...] ...)
-           #:contracts ()
-           desc ...))]
-    [(fm #:id id [spec spec1 ...] ([non-term-id non-term-form ...] ...)
-         desc ...)
-     (syntax/loc stx
-       (fm #:kind #f #:id id #:literals () [spec spec1 ...]
-           ([non-term-id non-term-form ...] ...)
-           #:contracts ()
-           desc ...))]
-    [(fm #:kind kind #:literals lits [(spec-id . spec-rest) spec1 ...]
-         ([non-term-id non-term-form ...] ...)
-         desc ...)
-     (with-syntax ([(_ _ _ _ _ [spec . _] . _) stx])
-       (syntax/loc stx
-         (fm #:kind kind #:id spec-id #:literals lits [spec spec1 ...]
-             ([non-term-id non-term-form ...] ...)
-             desc ...)))]
-    [(fm #:literals lits [(spec-id . spec-rest) spec1 ...]
-         ([non-term-id non-term-form ...] ...)
-         desc ...)
-     (with-syntax ([(_ _ _ [spec . _] . _) stx])
-       (syntax/loc stx
-         (fm #:kind #f #:id spec-id #:literals lits [spec spec1 ...]
-             ([non-term-id non-term-form ...] ...)
-             desc ...)))]
-    [(fm #:kind kind [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)
-     (syntax/loc stx
-       (fm #:kind kind #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...)
-           desc ...))]
-    [(fm [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)
-     (syntax/loc stx
-       (fm #:kind #f #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...)
-           desc ...))]))
+                       (lambda () (list desc ...)))))]))
 
 (define-syntax (defform* stx)
-  (syntax-case stx ()
-    [(_ #:kind kind #:id id #:literals lits [spec ...] desc ...)
+  (syntax-parse stx
+    [(_ k:kind-kw d:id-kw l:literals-kw [spec ...] desc ...)
      (syntax/loc stx
-       (defform*/subs #:kind kind #:id id #:literals lits [spec ...] () desc ...))]
-    [(_ #:id id #:literals lits [spec ...] desc ...)
-     (syntax/loc stx
-       (defform*/subs #:id id #:literals lits [spec ...] () desc ...))]
-    [(_ #:kind kind #:literals lits [spec ...] desc ...)
-     (syntax/loc stx
-       (defform*/subs #:kind kind #:literals lits [spec ...] () desc ...))]
-    [(_ #:literals lits [spec ...] desc ...)
-     (syntax/loc stx
-       (defform*/subs #:literals lits [spec ...] () desc ...))]
-    [(_ #:kind kind #:id id [spec ...] desc ...)
-     (syntax/loc stx
-       (defform*/subs #:kind kind #:id id [spec ...] () desc ...))]
-    [(_ #:id id [spec ...] desc ...)
-     (syntax/loc stx
-       (defform*/subs #:id id [spec ...] () desc ...))]
-    [(_ #:kind kind [spec ...] desc ...)
-     (syntax/loc stx
-       (defform*/subs #:kind kind [spec ...] () desc ...))]
-    [(_ [spec ...] desc ...)
-     (syntax/loc stx
-       (defform*/subs [spec ...] () desc ...))]))
+       (defform*/subs #:kind k.kind 
+         #:id [d.defined-id d.defined-id-expr] 
+         #:literals (l.lit ...)
+         [spec ...] () desc ...))]))
 
 (define-syntax (defform stx)
-  (syntax-case stx ()
-    [(_ #:kind kind #:id id #:literals (lit ...) spec desc ...)
+  (syntax-parse stx
+    [(_ k:kind-kw d:id-kw l:literals-kw spec desc ...)
      (syntax/loc stx
-       (defform*/subs #:kind kind #:id id #:literals (lit ...) [spec] () desc ...))]
-    [(_ #:id id #:literals (lit ...) spec desc ...)
-     (syntax/loc stx
-       (defform*/subs #:id id #:literals (lit ...) [spec] () desc ...))]
-    [(_ #:kind kind #:id id spec desc ...)
-     (syntax/loc stx
-       (defform*/subs #:kind kind #:id id #:literals () [spec] () desc ...))]
-    [(_ #:id id spec desc ...)
-     (syntax/loc stx
-       (defform*/subs #:id id #:literals () [spec] () desc ...))]
-    [(_ #:literals (lit ...) spec desc ...)
-     (syntax/loc stx
-       (defform*/subs #:literals (lit ...) [spec] () desc ...))]
-    [(_ #:kind kind #:literals (lit ...) spec desc ...)
-     (syntax/loc stx
-       (defform*/subs #:kind kind #:literals (lit ...) [spec] () desc ...))]
-    [(_ #:kind kind spec desc ...)
-     (syntax/loc stx
-       (defform*/subs #:kind kind [spec] () desc ...))]
-    [(_ spec desc ...)
-     (syntax/loc stx
-       (defform*/subs [spec] () desc ...))]))
+       (defform*/subs #:kind k.kind 
+         #:id [d.defined-id d.defined-id-expr] 
+         #:literals (l.lit ...)
+         [spec] () desc ...))]))
 
 (define-syntax (defform/subs stx)
-  (syntax-case stx ()
-    [(_ #:kind kind #:id id #:literals lits spec subs desc ...)
+  (syntax-parse stx
+    [(_ k:kind-kw d:id-kw l:literals-kw spec subs desc ...)
      (syntax/loc stx
-       (defform*/subs #:kind kind #:id id #:literals lits [spec] subs desc ...))]
-    [(_ #:id id #:literals lits spec subs desc ...)
-     (syntax/loc stx
-       (defform*/subs #:id id #:literals lits [spec] subs desc ...))]
-    [(_ #:kind kind #:id id spec subs desc ...)
-     (syntax/loc stx
-       (defform*/subs #:kind kind #:id id #:literals () [spec] subs desc ...))]
-    [(_ #:id id spec subs desc ...)
-     (syntax/loc stx
-       (defform*/subs #:id id #:literals () [spec] subs desc ...))]
-    [(_ #:kind kind #:literals lits spec subs desc ...)
-     (syntax/loc stx
-       (defform*/subs #:kind kind #:literals lits [spec] subs desc ...))]
-    [(_ #:literals lits spec subs desc ...)
-     (syntax/loc stx
-       (defform*/subs #:literals lits [spec] subs desc ...))]
-    [(_ #:kind kind spec subs desc ...)
-     (syntax/loc stx
-       (defform*/subs #:kind kind [spec] subs desc ...))]
-    [(_ spec subs desc ...)
-     (syntax/loc stx
-       (defform*/subs [spec] subs desc ...))]))
+       (defform*/subs #:kind k.kind 
+         #:id [d.defined-id d.defined-id-expr] 
+         #:literals (l.lit ...)
+         [spec] subs desc ...))]))
 
 (define-syntax (defform/none stx)
-  (syntax-case stx ()
-    [(_ #:kind kind #:literals (lit ...) spec #:contracts ([contract-id contract-expr] ...) desc ...)
-     (begin
-       (for-each (lambda (id)
-                   (unless (identifier? id)
-                     (raise-syntax-error #f
-                                         "expected an identifier for a literal"
-                                         stx
-                                         id)))
-                 (syntax->list #'(lit ...)))
-       #'(with-togetherable-racket-variables
-          (lit ...)
-          ([form/none spec])
-          (*defforms kind #f
-                     '(spec) (list (lambda (ignored) (racketblock0/form spec)))
-                     null null
-                     (list (list (lambda () (racket contract-id))
-                                 (lambda () (racketblock0 contract-expr)))
-                           ...)
-                     (lambda () (list desc ...)))))]
-    [(fm #:literals (lit ...) spec #:contracts ([contract-id contract-expr] ...) desc ...)
+  (syntax-parse stx
+    [(_ k:kind-kw l:literals-kw spec c:contracts-kw desc ...)
      (syntax/loc stx
-       (fm #:kind #f #:literals (lit ...) spec #:contracts ([contract-id contract-expr] ...) desc ...))]
-    [(fm #:kind kind #:literals (lit ...) spec desc ...)
-     (syntax/loc stx
-       (fm #:kind kind #:literals (lit ...) spec #:contracts () desc ...))]
-    [(fm #:literals (lit ...) spec desc ...)
-     (syntax/loc stx
-       (fm #:literals (lit ...) spec #:contracts () desc ...))]
-    [(fm #:kind kind spec desc ...)
-     (syntax/loc stx
-       (fm #:kind kind #:literals () spec desc ...))]
-    [(fm spec desc ...)
-     (syntax/loc stx
-       (fm #:literals () spec desc ...))]))
+       (with-togetherable-racket-variables
+        (l.lit ...)
+        ([form/none spec])
+        (*defforms k.kind #f
+                   '(spec) (list (lambda (ignored) (racketblock0/form spec)))
+                   null null
+                   (list (list (lambda () (racket c.contract-id))
+                               (lambda () (racketblock0 c.contract-expr)))
+                         ...)
+                   (lambda () (list desc ...)))))]))
 
 (define-syntax (defidform/inline stx)
   (syntax-case stx (unsyntax)
@@ -254,21 +153,18 @@
      #'(defform-site id-expr)]))
 
 (define-syntax (defidform stx)
-  (syntax-case stx ()
-    [(_ #:kind kind spec-id desc ...)
+  (syntax-parse stx
+    [(_ k:kind-kw spec-id desc ...)
      #'(with-togetherable-racket-variables
         ()
         ()
-        (*defforms kind (quote-syntax/loc spec-id)
+        (*defforms k.kind (quote-syntax/loc spec-id)
                    '(spec-id)
                    (list (lambda (x) (make-omitable-paragraph (list x))))
                    null
                    null
                    null
-                   (lambda () (list desc ...))))]
-    [(fm spec-id desc ...)
-     (syntax/loc stx
-       (fm #:kind #f spec-id desc ...))]))
+                   (lambda () (list desc ...))))]))
 
 (define (into-blockquote s)
   (make-blockquote "leftindent"
@@ -284,46 +180,40 @@
   (syntax-case stx ()
     [(_ . rest) #'(into-blockquote (defform* . rest))]))
 
-(define-syntax spec?form/subs
-  (syntax-rules ()
-    [(_ has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
-        #:contracts ([contract-nonterm contract-expr] ...)
+(define-syntax (spec?form/subs stx)
+  (syntax-parse stx
+    [(_ has-kw? l:literals-kw spec g:grammar
+        c:contracts-kw
         desc ...)
-     (with-racket-variables
-      (lit ...)
-      ([form/maybe (has-kw? spec)]
-       [non-term (non-term-id non-term-form ...)] ...)
-      (*specsubform 'spec '(lit ...) (lambda () (racketblock0/form spec))
-                    '((non-term-id non-term-form ...) ...)
-                    (list (list (lambda () (racket non-term-id))
-                                (lambda () (racketblock0/form non-term-form))
-                                ...)
-                          ...)
-                    (list (list (lambda () (racket contract-nonterm))
-                                (lambda () (racketblock0 contract-expr)))
-                          ...)
-                    (lambda () (list desc ...))))]
-    [(_ has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
-        desc ...)
-     (spec?form/subs has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
-                     #:contracts ()
-                     desc ...)]))
+     (syntax/loc stx
+       (with-racket-variables
+        (l.lit ...)
+        ([form/maybe (has-kw? spec)]
+         [non-term (g.non-term-id g.non-term-form ...)] ...)
+        (*specsubform 'spec '(l.lit ...) (lambda () (racketblock0/form spec))
+                      '((g.non-term-id g.non-term-form ...) ...)
+                      (list (list (lambda () (racket g.non-term-id))
+                                  (lambda () (racketblock0/form g.non-term-form))
+                                  ...)
+                            ...)
+                      (list (list (lambda () (racket c.contract-nonterm))
+                                  (lambda () (racketblock0 c.contract-expr)))
+                            ...)
+                      (lambda () (list desc ...)))))]))
 
-(define-syntax specsubform
-  (syntax-rules ()
-    [(_ #:literals (lit ...) spec desc ...)
-     (spec?form/subs #f #:literals (lit ...) spec () desc ...)]
-    [(_ spec desc ...)
-     (specsubform #:literals () spec desc ...)]))
+(define-syntax (specsubform stx)
+  (syntax-parse stx
+    [(_ l:literals-kw spec desc ...)
+     (syntax/loc stx
+       (spec?form/subs #f #:literals (l.lit ...) spec () desc ...))]))
 
-(define-syntax specsubform/subs
-  (syntax-rules ()
-    [(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
-        desc ...)
-     (spec?form/subs #f #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
-                     desc ...)]
-    [(_ spec subs desc ...)
-     (specsubform/subs #:literals () spec subs desc ...)]))
+(define-syntax (specsubform/subs stx)
+  (syntax-parse stx
+    [(_ l:literals-kw spec g:grammar desc ...)
+     (syntax/loc stx
+       (spec?form/subs #f #:literals (l.lit ...) spec 
+                       ([g.non-term-id g.non-term-form ...] ...) 
+                       desc ...))]))
 
 (define-syntax-rule (specspecsubform spec desc ...)
   (make-blockquote "leftindent" (list (specsubform spec desc ...))))
@@ -338,15 +228,13 @@
     [(_ spec desc ...)
      (specform #:literals () spec desc ...)]))
 
-(define-syntax specform/subs
-  (syntax-rules ()
-    [(_ #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
+(define-syntax (specform/subs stx)
+  (syntax-parse stx
+    [(_ l:literals-kw spec g:grammar
         desc ...)
-     (spec?form/subs #t #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
-                     desc ...)]
-    [(_ spec ([non-term-id non-term-form ...] ...) desc ...)
-     (specform/subs #:literals () spec ([non-term-id non-term-form ...] ...)
-                    desc ...)]))
+     (syntax/loc stx
+       (spec?form/subs #t #:literals (l.lit ...) spec ([g.non-term-id g.non-term-form ...] ...)
+                       desc ...))]))
 
 (define-syntax-rule (specsubform/inline spec desc ...)
   (with-racket-variables
diff --git a/collects/scribble/private/manual-proc.rkt b/collects/scribble/private/manual-proc.rkt
index bb9893eb..65070869 100644
--- a/collects/scribble/private/manual-proc.rkt
+++ b/collects/scribble/private/manual-proc.rkt
@@ -17,7 +17,8 @@
          "on-demand.rkt"
          scheme/string
          scheme/list
-         (for-syntax racket/base)
+         (for-syntax racket/base
+                     syntax/parse)
          (for-label racket/base
                     racket/contract
                     racket/class))
@@ -78,11 +79,14 @@
 
 (define-syntax (extract-proc-id stx)
   (syntax-case stx ()
-    [(_ id)
+    [(_ k e id)
      (identifier? #'id)
-     #`(quote-syntax/loc id)]
-    [(_ (proto arg ...))
-     #'(extract-proc-id proto)]
+     (if (and (syntax-e #'k)
+              (free-identifier=? #'k #'id))
+         #'e
+         #`(quote-syntax/loc id))]
+    [(_ k e (proto arg ...))
+     #'(extract-proc-id k e proto)]
     [(_ thing) (raise-syntax-error 'defproc "bad prototype" #'thing)]))
 
 (define-syntax (arg-contracts stx)
@@ -113,39 +117,62 @@
                            "expected a result contract, found a string" #'c)
        #'(racketblock0 c))]))
 
-(define-syntax defproc
-  (syntax-rules ()
-    [(_ #:kind kind (id arg ...) result desc ...)
-     (defproc* #:kind kind [[(id arg ...) result]] desc ...)]
-    [(_ (id arg ...) result desc ...)
-     (defproc* [[(id arg ...) result]] desc ...)]))
+(begin-for-syntax
+ (define-splicing-syntax-class kind-kw
+   #:description "#:kind keyword"
+   (pattern (~optional (~seq #:kind kind)
+                       #:defaults ([kind #'#f]))))
 
-(define-syntax defproc*
-  (syntax-rules ()
-    [(_ #:kind kind #:mode m #:within cl [[proto result] ...] desc ...)
-     (with-togetherable-racket-variables
-      ()
-      ([proc proto] ...)
-      (*defproc kind
-                'm (quote-syntax/loc cl)
-                (list (extract-proc-id proto) ...)
-                '[proto ...]
-                (list (arg-contracts proto) ...)
-                (list (arg-defaults proto) ...)
-                (list (lambda () (result-contract result)) ...)
-                (lambda () (list desc ...))))]
-    [(_ #:mode m #:within cl [[proto result] ...] desc ...)
-     (defproc* #:kind #f #:mode m #:within cl [[proto result] ...] desc ...)]
-    [(_ #:kind kind [[proto result] ...] desc ...)
-     (defproc* #:kind kind #:mode procedure #:within #f [[proto result] ...] desc ...)]
-    [(_ [[proto result] ...] desc ...)
-     (defproc* #:kind #f #:mode procedure #:within #f [[proto result] ...] desc ...)]))
+ (define-syntax-class id-or-false
+   (pattern i:id)
+   (pattern #f #:with i #'#f))
+   
+ (define-splicing-syntax-class id-kw
+   #:description "#:id keyword"
+   (pattern (~optional (~seq #:id [key:id-or-false expr])
+                       #:defaults ([key #'#f]
+                                   [expr #'#f]))))
+ 
+ (define-splicing-syntax-class mode-kw
+   #:description "#:mode keyword"
+   (pattern (~optional (~seq #:mode m:id)
+                       #:defaults ([m #'procedure]))))
+
+ (define-splicing-syntax-class within-kw
+   #:description "#:within keyword"
+   (pattern (~optional (~seq #:within cl:id)
+                       #:defaults ([cl #'#f]))))
+ )
+
+(define-syntax (defproc stx)
+  (syntax-parse stx
+    [(_ kind:kind-kw i:id-kw (id arg ...) result desc ...)
+     (syntax/loc stx
+       (defproc* #:kind kind.kind #:id [i.key i.expr] [[(id arg ...) result]] desc ...))]))
+
+(define-syntax (defproc* stx)
+  (syntax-parse stx
+    [(_ kind:kind-kw d:id-kw mode:mode-kw within:within-kw [[proto result] ...] desc ...)
+     (syntax/loc stx
+       (with-togetherable-racket-variables
+        ()
+        ([proc proto] ...)
+        (let ([alt-id d.expr])
+          (*defproc kind.kind
+                    'mode.m (quote-syntax/loc within.cl)
+                    (list (extract-proc-id d.key alt-id proto) ...)
+                    'd.key
+                    '[proto ...]
+                    (list (arg-contracts proto) ...)
+                    (list (arg-defaults proto) ...)
+                    (list (lambda () (result-contract result)) ...)
+                    (lambda () (list desc ...))))))]))
 
 (define-struct arg
   (special? kw id optional? starts-optional? ends-optional? num-closers))
 
 (define (*defproc kind mode within-id
-                  stx-ids prototypes arg-contractss arg-valss result-contracts
+                  stx-ids sym prototypes arg-contractss arg-valss result-contracts
                   content-thunk)
   (define max-proto-width (current-display-width))
   (define ((arg->elem show-opt-start?) arg)
@@ -240,9 +267,14 @@
                                       (arg-id (cadr s)))))
                      (+ 1 (string-length (symbol->string (arg-id (cadr s)))))
                      0)))))))))
-  (define (extract-id p)
+  (define (extract-id p stx-id)
     (let loop ([p p])
-      (if (symbol? (car p)) (car p) (loop (car p)))))
+      (if (symbol? (car p)) 
+          (let ([s (car p)])
+            (if (eq? s sym)
+                (syntax-e stx-id)
+                (car p)))
+          (loop (car p)))))
   (define (do-one stx-id prototype args arg-contracts arg-vals result-contract
                   first? add-background-label?)
     (let ([names (remq* '(... ...+) (map arg-id args))])
@@ -262,7 +294,7 @@
           (list (racket send) spacer
                 (name-this-object (syntax-e within-id)) spacer
                 (if first?
-                  (let* ([mname (extract-id prototype)]
+                  (let* ([mname (extract-id prototype stx-id)]
                          [target-maker (id-to-target-maker within-id #f)]
                          [content (list (*method mname within-id))])
                     (if target-maker
@@ -285,11 +317,11 @@
                                        libs mname ctag)))))
                             tag))))
                       (car content)))
-                  (*method (extract-id prototype) within-id))))]
+                  (*method (extract-id prototype stx-id) within-id))))]
         [first?
+         (define the-id (extract-id prototype stx-id))
          (let ([target-maker (id-to-target-maker stx-id #t)]
-               [content (list (definition-site (extract-id prototype)
-                                               stx-id #f))])
+               [content (list (definition-site the-id stx-id #f))])
            (if target-maker
              (target-maker
               content
@@ -298,21 +330,20 @@
                  #f
                  (list (make-index-element
                         #f content tag
-                        (list (datum-intern-literal (symbol->string (extract-id prototype))))
+                        (list (datum-intern-literal (symbol->string the-id)))
                         content
                         (with-exporting-libraries
                          (lambda (libs)
-                           (make-procedure-index-desc (extract-id prototype)
-                                                      libs)))))
+                           (make-procedure-index-desc the-id libs)))))
                  tag)))
              (car content)))]
         [else
+         (define the-id (extract-id prototype stx-id))
          (annote-exporting-library
           (let ([sig (current-signature)])
             (if sig
-              (*sig-elem (sig-id sig) (extract-id prototype))
-              (to-element (make-just-context (extract-id prototype)
-                                             stx-id)))))]))
+              (*sig-elem (sig-id sig) the-id)
+              (to-element (make-just-context the-id stx-id)))))]))
     (define p-depth (prototype-depth prototype))
     (define flat-size (+ (prototype-size args + + #f)
                          p-depth
@@ -495,12 +526,13 @@
        (append-map
         do-one
         stx-ids prototypes all-args arg-contractss arg-valss result-contracts
-        (let loop ([ps prototypes] [accum null])
+        (let loop ([ps prototypes] [stx-ids stx-ids] [accum null])
           (cond [(null? ps) null]
-                [(ormap (lambda (a) (eq? (extract-id (car ps)) a)) accum)
-                 (cons #f (loop (cdr ps) accum))]
+                [(ormap (lambda (a) (eq? (extract-id (car ps) (car stx-ids)) a)) accum)
+                 (cons #f (loop (cdr ps) (cdr stx-ids) accum))]
                 [else (cons #t (loop (cdr ps)
-                                     (cons (extract-id (car ps)) accum)))]))
+                                     (cdr stx-ids)
+                                     (cons (extract-id (car ps) (car stx-ids)) accum)))]))
         (for/list ([p (in-list prototypes)]
                    [i (in-naturals)])
           (= i 0))))))
diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl
index 141eba67..027536db 100644
--- a/collects/scribblings/scribble/manual.scrbl
+++ b/collects/scribblings/scribble/manual.scrbl
@@ -671,7 +671,7 @@ sub-sections.}
 @; ------------------------------------------------------------------------
 @section[#:tag "doc-forms"]{Documenting Forms, Functions, Structure Types, and Values}
 
-@defform/subs[(defproc maybe-kind prototype
+@defform/subs[(defproc maybe-kind maybe-id prototype
                        result-contract-expr-datum
                        pre-flow ...)
               ([prototype (id arg-spec ...)
@@ -684,6 +684,8 @@ sub-sections.}
                          ellipses+]
                [maybe-kind code:blank
                            (code:line #:kind kind-string-expr)]
+               [maybe-id code:blank
+                         (code:line #:id [src-id dest-id-expr])]
                [ellipses @#,lit-ellipses]
                [ellipses+ @#,lit-ellipses+])]{
 
@@ -747,10 +749,17 @@ An optional @racket[#:kind] specification chooses the decorative
 label, which defaults to @racket["procedure"]. A @racket[#f]
 result for @racket[kind-string-expr] uses the default, otherwise
 @racket[kind-string-expr] should produce a string. An alternate
-label should be all lowercase.}
+label should be all lowercase.
 
+If @racket[#:id [src-id dest-id-expr]] is supplied, then
+@racket[src-id] is the identifier as it appears in the
+@racket[prototype] (to be replaced by a defining instance), and
+@racket[dest-id-expr] produces the identifier to be documented in
+place of @racket[src-id]. This split between @racket[src-id] and
+@racket[dest-id-expr] roles is useful for functional abstraction of
+@racket[defproc].}
 
-@defform[(defproc* maybe-kind
+@defform[(defproc* maybe-kind maybe-id
                    ([prototype
                      result-contract-expr-datum] ...)
                    pre-flow ...)]{