syntax/parse: support pvar:literal patterns

pkgs/racket-pkgs/racket-doc/syntax/scribblings/parse/patterns.scrbl

@@ -36,6 +36,7 @@ means specifically @tech{@Spattern}.
                 [S-pattern
                  pvar-id
                  pvar-id:syntax-class-id
+                 pvar-id:literal-id
                  literal-id
                  (@#,ref[~var s-] id)
                  (@#,ref[~var s+] id syntax-class-id maybe-role)
@@ -241,6 +242,18 @@ An identifier can be either a @tech{pattern variable}, an
   @svar[pvar-id].
 }
 
+@item{If @racket[id] is of the form @racket[_pvar-id:literal-id],
+  where @racket[_literal-id] is in the literals list, then it is
+  equivalent to @racket[(~and (~var _pvar-id) literal-id)].
+
+  @myexamples[
+    (require (only-in racket/base [define def]))
+    (syntax-parse #'(def x 7)
+      #:literals (define)
+      [(d:define var:id body:expr) #'d])
+  ]
+}
+
 @item{Otherwise, @racket[id] is a @tech{pattern variable}, and the
 pattern is equivalent to @racket[(~var id)].
 }

racket/collects/syntax/parse/private/rep-data.rkt

@@ -252,7 +252,7 @@ expressions are duplicated, and may be evaluated in different scopes.
       stxclass?)]
  [split-id/get-stxclass
   (-> identifier? DeclEnv/c
-      (values identifier? (or/c stxclass? #f)))])
+      (values identifier? (or/c stxclass? den:lit? den:datum-lit? #f)))])
 
 ;; stxclass-lookup-config : (parameterof (U 'no 'try 'yes))
 ;;  'no means don't lookup, always use dummy (no nested attrs)
@@ -288,12 +288,16 @@ expressions are duplicated, and may be evaluated in different scopes.
          => (lambda (m)
               (define id
                 (datum->syntax id0 (string->symbol (cadr m)) id0 id0))
-              (define scname
+              (define suffix
                 (datum->syntax id0 (string->symbol (caddr m)) id0 id0))
-              (declenv-check-unbound decls id (syntax-e scname)
+              (declenv-check-unbound decls id (syntax-e suffix)
                                      #:blame-declare? #t)
-              (let ([sc (get-stxclass/check-arity scname id0 0 null)])
+              (let ([suffix-entry (declenv-lookup decls suffix)])
-                (values id sc)))]
+                (cond [(or (den:lit? suffix-entry) (den:datum-lit? suffix-entry))
+                       (values id suffix-entry)]
+                      [else
+                       (let ([sc (get-stxclass/check-arity suffix id0 0 null)])
+                         (values id sc))])))]
         [else (values id0 #f)]))
 
 ;; ----

racket/collects/syntax/parse/private/rep.rkt

@@ -686,9 +686,14 @@
         [(not (safe-name? id))
          (wrong-syntax id "expected identifier not starting with ~~ character")]
         [else
-         (let-values ([(name sc) (split-id/get-stxclass id decls)])
+         (let-values ([(name suffix) (split-id/get-stxclass id decls)])
-           (cond [sc
+           (cond [(stxclass? suffix)
-                  (parse-pat:var* id allow-head? name sc no-arguments "." #f #f)]
+                  (parse-pat:var* id allow-head? name suffix no-arguments "." #f #f)]
+                 [(or (den:lit? suffix) (den:datum-lit? suffix))
+                  (create-pat:and
+                   (list
+                    (create-pat:var name #f no-arguments null #f #t #f)
+                    (parse-pat:id/entry id decls allow-head? suffix)))]
                  [(declenv-apply-conventions decls id)
                   => (lambda (entry) (parse-pat:id/entry id decls allow-head? entry))]
                  [else (create-pat:var name #f no-arguments null #f #t #f)]))]))